From a4c61932c8bd87629ffedc19939757529b41a369 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 8 Apr 2024 08:42:57 +0100 Subject: [PATCH 01/36] Add import/export lists --- config/sysdep.f90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/config/sysdep.f90 b/config/sysdep.f90 index e08746a..65df6ba 100644 --- a/config/sysdep.f90 +++ b/config/sysdep.f90 @@ -66,6 +66,8 @@ module pm_sysdep ! ************ Compiler defaults **************** integer,parameter:: pm_default_ftn_dims=15 logical,parameter:: pm_default_ftn_has_contiguous=.true. + integer,parameter:: pm_default_ftn_lines=255 + integer,parameter:: pm_default_ftn_max_stack_array=10*1024*1024 ! ************ Memory model ********************* @@ -80,8 +82,9 @@ module pm_sysdep ! Types used by memory model (block offsets,object sizes,bitmap flags) - ! integer,parameter:: pm_p=kind(1) ! Pointer offsets, object types + + ! integer,parameter:: pm_p=kind(1) ! Pointer offsets, object types + ! flags (>~24 bits, typically int) + integer,parameter:: pm_p=8 integer,parameter:: pm_f=kind(1) ! Bitmap storage (integer word) @@ -166,7 +169,11 @@ module pm_sysdep ! Long long integers - big enough to address any file integer,parameter:: pm_lln=MPI_OFFSET_KIND - + + ! Maximum arguments to a PM procedure (must be 2**m-1 for some m) + integer,parameter:: pm_max_args=31 + character(len=3),parameter:: pm_maxargs_str=' 31' + contains From 0d09332723ea6c0e836e2305cee85756b962aff0 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 8 Apr 2024 08:59:23 +0100 Subject: [PATCH 02/36] Import/Export lists --- pm/Makefile | 12 +- src/array.f90 | 28 +- src/cfortran.f90 | 2690 +++++++++++++++++++++++++++++++++------------- src/codegen.f90 | 611 +++-------- src/infer.f90 | 502 ++++----- src/main.f90 | 9 +- src/parser.f90 | 67 +- src/sysdefs.f90 | 25 +- src/types.f90 | 1641 ++++++++++++---------------- src/vm.f90 | 2 +- src/vmdefs.f90 | 190 +++- src/wcoder.f90 | 150 +-- 12 files changed, 3297 insertions(+), 2630 deletions(-) diff --git a/pm/Makefile b/pm/Makefile index ed92415..1e3f3f5 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -65,25 +65,25 @@ symbol.o : ../src/symbol.f90 opts.o hash.o memory.o kinds.o pcomp.o sysdep.o lib.o : ../src/lib.f90 symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -vmdefs.o : ../src/vmdefs.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +types.o : ../src/types.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -parser.o : ../src/parser.f90 types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +vmdefs.o : ../src/vmdefs.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -types.o : ../src/types.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +parser.o : ../src/parser.f90 types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -array.o : ../src/array.f90 types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +array.o : ../src/array.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -parlib.o : ../src/parlib.f90 array.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +parlib.o : ../src/parlib.f90 array.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(PC) $(PFLAGS) -c $< linker.o : ../src/linker.f90 parser.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -sysdefs.o : ../src/sysdefs.f90 vmdefs.o parser.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +sysdefs.o : ../src/sysdefs.f90 vmdefs.o parser.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< codegen.o : ../src/codegen.f90 parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o diff --git a/src/array.f90 b/src/array.f90 index 0ad9968..c8e82fb 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -1176,8 +1176,8 @@ recursive subroutine export_vector(context,v,e,import_vec) integer:: k,errno tno=pm_fast_typeof(v) if(pm_fast_typeof(e)/=tno) then - write(*,*) trim(pm_typ_as_string(context,tno)),'<>',& - trim(pm_typ_as_string(context,pm_fast_typeof(e))) + write(*,*) trim(pm_type_as_string(context,tno)),'<>',& + trim(pm_type_as_string(context,pm_fast_typeof(e))) call pm_panic('export_vector') endif n=pm_fast_esize(v) @@ -1706,7 +1706,7 @@ recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(p enddo enddo case default - write(*,*) '%%',trim(pm_typ_as_string(context,tno)),tno,pm_dref_type + write(*,*) '%%',trim(pm_type_as_string(context,tno)),tno,pm_dref_type call pm_panic('Make vector') end select contains @@ -2060,8 +2060,8 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) tno=pm_fast_typeof(lhs) !!$ if(full_type(lhs)/=full_type(rhs)) then !!$ errno=vector_type_error -!!$ write(*,*) 'Full types',pm_typ_as_string(context,full_type(lhs)),& -!!$ pm_typ_as_string(context,full_type(rhs)) +!!$ write(*,*) 'Full types',pm_type_as_string(context,full_type(lhs)),& +!!$ pm_type_as_string(context,full_type(rhs)) !!$ !call pm_dump_tree(context,6,lhs,2) !!$ !call pm_dump_tree(context,6,rhs,2) !!$ return @@ -2314,8 +2314,8 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) endif case default - write(*,*) 'vector assign',trim(pm_typ_as_string(context,int(tno))),tno,& - 2595,trim(pm_typ_as_string(context,2595)) + write(*,*) 'vector assign',trim(pm_type_as_string(context,int(tno))),tno,& + 2595,trim(pm_type_as_string(context,2595)) end select contains @@ -3411,8 +3411,8 @@ recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) type(pm_ptr):: len,off,avec,len2,off2,avec2 tno=pm_fast_typeof(v) if(full_type(e)/=full_type(v)) then - write(*,*) trim(pm_typ_as_string(context,tno)),& - '<-->',trim(pm_typ_as_string(context,pm_fast_typeof(e))) + write(*,*) trim(pm_type_as_string(context,tno)),& + '<-->',trim(pm_type_as_string(context,pm_fast_typeof(e))) errno=vector_type_error return endif @@ -3995,7 +3995,7 @@ recursive subroutine vector_dump(context,v,depth) write(*,*) spaces(1:depth*2),')' case(pm_struct_type,pm_rec_type) tno=full_type(v) - name=pm_typ_vect(context,tno) + name=pm_type_vect(context,tno) name=pm_name_val(context,pm_tv_name(name)) tno=name%data%i(name%offset) if(k==pm_struct_type) then @@ -4019,7 +4019,7 @@ recursive subroutine vector_dump(context,v,depth) trim(pm_name_as_string(context,int(v%offset))),'}' case(pm_type) write(*,*) spaces(1:depth*2),'type{',& - trim(pm_typ_as_string(context,int(v%offset))),'}' + trim(pm_type_as_string(context,int(v%offset))),'}' case default call pm_dump_tree(context,6,v,depth) end select @@ -4077,7 +4077,7 @@ end subroutine output call output(context,spaces(1:depth*2)//')') case(pm_struct_type,pm_rec_type) tno=full_type(v) - name=pm_typ_vect(context,tno) + name=pm_type_vect(context,tno) name=pm_name_val(context,pm_tv_name(name)) tno=name%data%i(name%offset) if(k==pm_struct_type) then @@ -4104,7 +4104,7 @@ end subroutine output case(pm_null) call output(context,spaces(1:depth*2)//'null') case(pm_type) - call output(context,spaces(1:depth*2)//trim(pm_typ_as_string(context,int(v%offset)))) + call output(context,spaces(1:depth*2)//trim(pm_type_as_string(context,int(v%offset)))) case(pm_proc) call output(context,spaces(1:depth*2)//'proc('//& trim(pm_name_as_string(context,int(v%offset)))//')') @@ -4115,7 +4115,7 @@ end subroutine output case(pm_int:pm_complex256) call output(context,spaces(1:depth*2)//trim(pm_number_as_string(context,v,j))) case default - call output(context,spaces(1:depth*2)//'?'//trim(pm_typ_as_string(context,k))) + call output(context,spaces(1:depth*2)//'?'//trim(pm_type_as_string(context,k))) end select contains diff --git a/src/cfortran.f90 b/src/cfortran.f90 index 6c53051..2a1a2b4 100644 --- a/src/cfortran.f90 +++ b/src/cfortran.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -38,6 +38,7 @@ module pm_backend implicit none logical,parameter:: debug_g=.false. + logical,parameter:: debug_opt=.false. ! Various limits integer,parameter:: ftn_max_line=130 @@ -46,21 +47,21 @@ module pm_backend integer,parameter:: max_levels=256 integer,parameter:: max_loop_stack=10*1024 + ! Variable descriptor type gvar integer:: tno ! Type - integer:: flags ! Flags from previous stage - integer:: gflags ! Flags applied in this stage + integer:: flags ! Flags integer:: state ! State engine (determines if needs to be stored as vector) integer:: start ! First instruction point var is used integer:: finish ! Last instruction point var is used - integer:: lthis ! Parallel context + integer:: depth ! Parallel context integer:: link ! Linked list of variables in creation order integer:: elink ! Linked list of variables in destruction order integer:: index ! Vector to store this variable (may be shared) integer:: free ! List of variables free for reuse (*not unused records*) integer:: oindex ! Index of variable in output from wordcode generator - integer:: outer_lthis ! Outermost parallel context in which variable is referenced + integer:: outer_depth ! Outermost parallel context in which variable is referenced logical:: finish_on_assign ! Last statement using this variable is assignment to another variable integer:: name ! PM name of variable @@ -78,13 +79,14 @@ module pm_backend integer,parameter:: var_state_closed=5 ! Local flags for variables - integer,parameter:: var_is_recycled=1 - integer,parameter:: var_is_async=2 - integer,parameter:: var_is_else_disabled=4 - integer,parameter:: var_is_comm_op_par=8 - integer,parameter:: var_is_used=16 - integer,parameter:: var_is_reused=32 - integer,parameter:: var_is_stacked_ve=64 + integer,parameter:: var_is_recycled= 1*v_extra_flags + integer,parameter:: var_is_async= 2*v_extra_flags + integer,parameter:: var_is_else_disabled=4*v_extra_flags + integer,parameter:: var_is_comm_op_par= 8*v_extra_flags + integer,parameter:: var_is_used= 16*v_extra_flags + integer,parameter:: var_is_reused= 32*v_extra_flags + integer,parameter:: var_is_stacked_ve= 64*v_extra_flags + integer,parameter:: var_is_modified= 128*v_extra_flags ! Loop modes integer,parameter:: loop_is_none=0 @@ -123,12 +125,12 @@ module pm_backend ! Current proc type(pm_ptr):: fn - integer:: taints + integer:: taints,name,rvar,pvar,vevar ! Wordcodes for current proc integer,dimension(:),pointer:: codes integer,dimension(:),pointer:: vars - + ! Variables integer:: nvars,index integer,dimension(:),allocatable:: varindex @@ -137,7 +139,11 @@ module pm_backend ! Parallel loop frames type(gloop),dimension(0:max_loop_stack):: lstack - integer:: lthis,ltop + integer:: depth,ltop + + ! Standard scopes + integer,dimension(0:max_loop_stack):: cstack + integer:: ctop ! VE used by last instruction previously coded integer:: last_ve @@ -156,6 +162,13 @@ module pm_backend character(len=ftn_max_line):: linebuffer integer:: n,outunit integer:: line_breaks + + ! Stack used for various purposes + integer,dimension(:),allocatable:: wstack + integer:: wtop,wbot,wfree,nwfree,wmax + + ! Book-keeping for various optimisations + integer:: local_taints end type gen_state @@ -208,6 +221,7 @@ subroutine gen_prog(context,p,poly_cache,typeset,iunit) g%line_breaks=0 g%n=0 + ! Program code call out_line_noindent(g,'PROGRAM PM') i=iunit @@ -239,6 +253,7 @@ subroutine gen_procs ! Generate procedure to create required MPI types call gen_mpi_types(g) + end subroutine gen_procs ! Output type definitions (called from rtime.inc) @@ -252,6 +267,24 @@ end subroutine out_types end subroutine gen_prog + function g_proc_taints(g,n) result(taints) + type(gen_state):: g + integer,intent(in):: n + integer:: taints + type(pm_ptr):: p + p=pm_dict_val(g%context,g%procs,int(n+1,pm_p)) + p=p%data%ptr(p%offset+2) + taints=p%offset + end function g_proc_taints + + subroutine g_print_out(g,iunit,index,tsets) + type(gen_state):: g + integer,intent(in):: iunit,index + logical,intent(in),optional:: tsets + call print_comp_proc(g%context,iunit,g%name,index,g%rvar,g%vevar,g%pvar,& + g%codes,1,g%vars,g%procs,g%fn%data%ptr(g%fn%offset:),2,.true.,g%wstack,tsets,& + oindex=g%vardata%oindex) + end subroutine g_print_out !=========================================== ! Generate code for a single procedure @@ -260,7 +293,7 @@ subroutine gen_proc(g,p,no) type(gen_state):: g type(pm_ptr),intent(in)::p integer,intent(in):: no - integer:: i,n,rvar,pvar,vevar,name + integer:: i,n,rvar,pvar,vevar,name,start type(pm_ptr)::q,taint,keys logical:: iscomm @@ -277,16 +310,12 @@ subroutine gen_proc(g,p,no) keys=p%data%ptr(p%offset+3) g%taints=taint%offset iscomm=iand(int(taint%offset),proc_is_comm)/=0 - - ! Output spacing / comment - call out_new_line(g) - call out_line_noindent(g,' !'//& - trim(pm_name_as_string(g%context,name))) - if(debug_g) then - write(*,*) 'OUT START> ',& - trim(pm_name_as_string(g%context,q%data%i(q%offset+2))) - endif + g%rvar=rvar + g%pvar=pvar + g%vevar=vevar + g%name=name + ! Set up variable data tables q=p%data%ptr(p%offset+1) g%vars=>q%data%i(q%offset:q%offset+pm_fast_esize(q)) @@ -296,25 +325,39 @@ subroutine gen_proc(g,p,no) g%nvars=0 g%varindex(1:n)=0 - ! Output procedure header - if(iand(int(taint%offset),proc_is_recursive)/=0) & - call out_str(g,'RECURSIVE ') - if(iand(int(taint%offset),proc_is_impure)==0) & - call out_str(g,'PURE ') - call out_str(g,'SUBROUTINE PM__P') - call out_idx(g,no) - if(pm_opts%ftn_name_procs.and.no>0) then - call out_ftn_name(g,name) - endif + call g_print_out(g,67,no+1) + + call init_g + ! Create variables + if(vevar/=-1) then + call create_var(g,vevar,.false.) + endif + if(.not.pm_fast_isnull(keys)) then + do i=0,pm_fast_esize(keys) + call create_var(g,keys%data%i(keys%offset+i),.false.) + enddo + endif + if(pvar/=-1) call create_var(g,pvar,.false.) + if(size(g%codes)>0) call create_vars_for_block(g,comp_op_start) + if(rvar/=-1) call create_var(g,rvar,.false.) + + start=comp_op_start + g%depth=1 + g%cstack(g%depth)=bset_new(g,0) + if(size(g%codes)>0)call record_vars_for_block(g,start) + + call g_print_out(g,69,no+1,.true.) + ! Phase I - analyse variable use to determine variable lifetimes ! and which variables need to be ! stored as vectors ! Also output necessary variable definition lines here - call init_g + g%ltop=-1 + g%depth=0 call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none + g%lstack(g%depth)%loop_mode=loop_is_none if(vevar/=-1) then call use_var(g,vevar) call cross_var(g,vevar) @@ -330,12 +373,30 @@ subroutine gen_proc(g,p,no) ! Phase II - analyse variable lifetimes to merge variables do i=0,g%ltop - g%lthis=i + g%depth=i call sort_var_list(g) call alloc_var_list(g) enddo ! Phase III - output necessary definition lines + ! Output procedure header + ! Output spacing / comment + call out_new_line(g) + call out_line_noindent(g,' !'//& + trim(pm_name_as_string(g%context,name))) + if(debug_g) then + write(*,*) 'OUT START> ',& + trim(pm_name_as_string(g%context,q%data%i(q%offset+2))) + endif + if(iand(int(taint%offset),proc_is_recursive)/=0) & + call out_str(g,'RECURSIVE ') + if(iand(int(taint%offset),proc_is_impure)==0) & + call out_str(g,'PURE ') + call out_str(g,'SUBROUTINE PM__P') + call out_idx(g,no) + if(pm_opts%ftn_name_procs.and.no>0) then + call out_ftn_name(g,name) + endif call out_char(g,'(') if(iscomm) then call out_str(g,'N1,') @@ -391,10 +452,17 @@ subroutine gen_proc(g,p,no) include 'fesize.inc' include 'fisnull.inc' subroutine init_g - g%lthis=0 + g%depth=0 g%ltop=0 g%lalt=-1 g%loop_contains_shared=.false. + if(allocated(g%wstack)) deallocate(g%wstack) + allocate(g%wstack(max_code_size)) + g%wtop=0 + g%wbot=max_code_size+1 + g%wmax=max_code_size + g%wfree=0 + g%nwfree=0 end subroutine init_g end subroutine gen_proc @@ -412,153 +480,1345 @@ function g_procname(g,n) result(name) end function g_procname !************************************************ - ! PHASE I - VARIABLE ASSIGNMENT + ! PHASE I - VARIABLE CREATION !************************************************ !=========================================== - ! Variable assignment phase for a code block + ! Create a variable entry for variables + ! referenced by any operation in the block !=========================================== - recursive subroutine gen_var_block(g,loc) + recursive subroutine create_vars_for_block(g,loc) type(gen_state):: g integer,intent(in):: loc integer:: l - if(debug_g) write(*,*) 'VAR BLOCK>' + if(debug_g) write(*,*) 'CREATE VARS FOR BLOCK>' l=loc + g%depth=g%depth+1 do while(l>0) - if(debug_g) write(*,*) 'DO VAR>',l - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,l) + call create_vars_for_op(g,l) l=g%codes(l) - if(debug_g) write(*,*) 'NEXT VAR',l enddo - if(debug_g) write(*,*) 'END VAR BLOCK>' - end subroutine gen_var_block + g%depth=g%depth-1 + if(debug_g) write(*,*) 'END CREATE VARS FOR BLOCK>' + end subroutine create_vars_for_block - !================================================== - ! Variable assignment phase for a single operation - !================================================== - recursive subroutine gen_var_op(g,l) + !================================================ + ! Create a variable entry for variables + ! referenced by any operation in the comm block + !=============================================== + recursive subroutine create_vars_for_comm_block(g,loc) + type(gen_state):: g + integer,intent(in):: loc + integer:: l,save_depth + if(debug_g) write(*,*) 'CREATE VARS FOR COMM BLOCK>' + l=loc + g%depth=g%depth+1 + do while(l>0) + call create_vars_for_op(g,l) + l=g%codes(l) + enddo + g%depth=g%depth-1 + if(debug_g) write(*,*) 'END CREATE VARS FOR COMM BLOCK>' + end subroutine create_vars_for_comm_block + + !=========================================== + ! Create a variable entry for any variable + ! referenced by an operation + !=========================================== + recursive subroutine create_vars_for_op(g,l) type(gen_state):: g integer,intent(in):: l - integer:: opcode,opcode2,n,arg - integer:: i,j,a,save_lthis,ll,var1,idx1 - logical:: save_loop_contains_shared - if(pm_debug_level>0) then - if(l>size(g%codes)) then - write(*,*) 'l=',l,size(g%codes) - call pm_panic('gen_var_op bad l') + integer:: opcode,n,a,is,i,flags + opcode=g%codes(l+comp_op_opcode) + n=iand(g%codes(l+comp_op_nargs),comp_op_nargs_mask) + a=l+comp_op_arg0 + call create_var(g,g%codes(a),.false.) + flags=op_flags(opcode) + if(iand(flags,op_1_block+op_2_blocks)/=0) then + if(iand(flags,op_has_comm_block)/=0) then + call create_vars_for_comm_block(g,g%codes(a+1)) + is=2 + elseif(iand(flags,op_1_block)/=0) then + call create_vars_for_block(g,g%codes(a+1)) + is=2 + else ! op_2_blocks + call create_vars_for_block(g,g%codes(a+1)) + call create_vars_for_block(g,g%codes(a+2)) + is=3 endif + else + is=1 endif + do i=is,n-1 + call create_var(g,g%codes(a+i),g%codes(a+i)<0) + enddo + !g%codes(l+comp_op_line)=-999 + end subroutine create_vars_for_op + + !===================================================== + ! Create a variable entry/entries for given argument + !===================================================== + recursive subroutine create_var(g,avar,modify) + type(gen_state),intent(inout):: g + integer,intent(in):: avar + logical,intent(in):: modify + integer:: kind,state,i,j,var,flags,tno + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + if(debug_g) write(*,*) 'CREATE VAR> ',var,g_index(g,var),& + g%depth + kind=g_kind(g,var) + select case(kind) + case(v_is_group) + do i=1,g_v1(g,var) + call create_var(g,g_ptr(g,var,i),modify) + enddo + case(v_is_sub,v_is_vsub) + call create_var(g,g_v1(g,var),modify) + call create_var(g,g_v2(g,var),modify) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + call create_var(g,g_v1(g,var),modify) + case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) + continue + case(v_is_cove) + call create_var(g,g_v2(g,var),modify) + g%varindex(var)=g%varindex(g_v2(g,var)) + case(v_is_alias) + call create_var(g,g_v1(g,var),modify) + g%varindex(var)=g%varindex(g_v1(g,var)) + case(v_is_chan_vect) + call create_var(g,g_v1(g,var),modify) + g%varindex(var)=g%varindex(g_v1(g,var)) + case default + i=g%varindex(var) + if(i==0) then + g%nvars=g%nvars+1 + if(debug_g) write(*,*) 'CREATE>',var,g%nvars + i=g%nvars + if(kind==v_is_parve) then + g%vardata(i)%tno=pm_logical + flags=v_is_param + g%vardata(i)%name=0 + elseif(kind==v_is_ve) then + call create_var(g,g_v1(g,var),modify) + g%vardata(i)%tno=pm_logical + flags=0 + g%vardata(i)%name=0 + else + flags=g_v2(g,var) + tno=g_type(g,var) + g%vardata(i)%tno=tno + if(iand(flags,v_is_array_par_vect)==0) then + g%vardata(i)%name=g_v1(g,var) + else + g%vardata(i)%name=0 + endif + endif + g%vardata(i)%depth=g%depth + g%vardata(i)%flags=flags + g%vardata(i)%state=var_state_unused + g%vardata(i)%index=0 + g%vardata(i)%oindex=var + g%varindex(var)=i + if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link + else + g%vardata(i)%depth=min(g%depth,g%vardata(i)%depth) + if(modify) g%vardata(i)%flags=ior(g%vardata(i)%flags,var_is_modified) + endif + end select + end subroutine create_var + + + !=========================================== + ! Create access sets for each operation + ! - including accesses from operations in + ! nested blocks + !=========================================== + recursive subroutine record_vars_for_block(g,loc) + type(gen_state):: g + integer,intent(inout):: loc + integer:: l,p + if(debug_g) write(*,*) 'RECORD VARS FOR BLOCK>' + l=loc + p=0 + do while(l>0) + call record_vars_for_op(g,l,p,loc) + p=l + l=g%codes(l) + enddo + if(debug_g) write(*,*) 'END RECORD VARS FOR BLOCK>' + end subroutine record_vars_for_block + + recursive subroutine record_vars_for_op(g,l,pre,blk) + type(gen_state):: g + integer,intent(in):: l,pre + integer,intent(inout):: blk + integer:: opcode,n,nret,a,is,i,flags,bset,acc + integer:: save_local_taints,vset,invar_vset,proc_taints + save_local_taints=g%local_taints + g%local_taints=0 opcode=g%codes(l+comp_op_opcode) - opcode2=g%codes(l+comp_op_opcode2) n=iand(g%codes(l+comp_op_nargs),comp_op_nargs_mask) + nret=iand(g%codes(l+comp_op_nargs),comp_op_nret_mask)/comp_op_nret_div a=l+comp_op_arg0 - - if(debug_g) then - write(*,*) 'l=',l,n,op_names(opcode) - write(*,*) 'VAR OP> ',g%lstack(g%lthis)%idx,l,op_names(opcode),n,& - '>>',g%codes(l:l+comp_op_arg0+n-1) + flags=op_flags(opcode) + + if(iand(flags,op_1_block+op_2_blocks)/=0) then + if(iand(flags,op_has_comm_block)/=0) then + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call pop_block + call schedule_comm_block(g,g%codes(a+1)) + is=2 + elseif(iand(flags,op_has_loop_block)/=0) then + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call pop_block + invar_vset=vset_extract_from_bset(g,bset,& + acc_read+acc_write,acc_read) + call loop_invar_motion_block(g,g%codes(a+1),& + pre,blk,invar_vset,g%depth) + call vset_drop(g,invar_vset) + is=2 + elseif(iand(flags,op_1_block)/=0) then + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call pop_block + is=2 + else ! op_2_blocks + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call record_vars_for_block(g,g%codes(a+2)) + call pop_block + is=3 + endif + else + is=1 endif - - select case(opcode) - case(op_if,op_if_shared,op_if_restart) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - case(op_if_shared_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - case(op_over,op_skip_empty) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call cross_all_vars(g) - case(op_head_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - case(op_loop) - save_loop_contains_shared=g%loop_contains_shared - g%loop_contains_shared=.false. - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - if(g%loop_contains_shared) then - g%codes(l+comp_op_opcode2)=ior(g%codes(l+comp_op_opcode2),2) + g%local_taints=ior(g%local_taints,flags) + if(opcode==op_call.or.opcode==op_comm_call) then + proc_taints=g_proc_taints(g,g%codes(l+comp_op_opcode2)) + if(iand(proc_taints,proc_is_dcomm)/=0) then + g%local_taints=ior(g%local_taints,op_is_comm) endif - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_loop,op_comm_loop_par) - save_loop_contains_shared=g%loop_contains_shared - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - call cross_all_vars(g) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_proc) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_inline_shared) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_shared_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_block) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+2)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_call,op_dref,op_wrap) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - call use_var(g,g%codes(a+i)) + if(iand(proc_taints,proc_is_file)/=0) then + g%local_taints=ior(g%local_taints,op_is_file) + endif + if(iand(proc_taints,proc_prints_out)/=0) then + g%local_taints=ior(g%local_taints,op_prints_out) + endif + endif + vset=vset_new(g,g%codes(l+comp_op_line),g%local_taints) + g%codes(l+comp_op_line)=vset + call record_var_access(g,g%codes(a),acc_read) + if(opcode==op_assign) then + acc=acc_read+acc_write + if(g_kind(g,g%codes(a+1))==v_is_basic) then + acc=acc_write + endif + if(iand(pm_type_flags(g%context,g_type(g,g%codes(a+1))),& + pm_type_has_array+pm_type_has_poly)/=0) then + acc=ior(acc,acc_alloc) + endif + call record_var_access(g,g%codes(a+1),acc) + call record_var_access(g,g%codes(a+2),acc_read) + else +!!$ if(iand(flags,op_allocates)/=0.and..false.) then +!!$ call record_var_access(g,g%codes(a+1),acc_write+acc_alloc) +!!$ else + + do i=is,is+nret-1 + call record_var_access(g,g%codes(a+i),acc_write) enddo - case(op_init_var) - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+1)) - case(op_comm_inline) !!! Obsolete? - call cross_all_vars(g) - case(op_sync) - call cross_all_vars(g) - case(op_broadcast_val,& - op_sync_mess,op_break_loop,& - op_read_file_tile,op_write_file_tile,op_broadcast,& - op_broadcast_shared,op_nested_loop,& - op_blocked_loop,op_isend_offset,op_irecv_offset,& - op_recv_offset,op_recv_offset_resend,op_isend_reply,& - op_recv_reply,op_isend_req,op_isend_assn,op_active,op_get_size) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) +!!$ endif + + do i=is+nret,n-1 + call record_var_access(g,g%codes(a+i),& + merge(acc_read+acc_write,acc_read,g%codes(a+i)<0)) enddo - case(op_remote_send_call,op_collect_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=6,n-1 !!! Dont use or cross outputs - call use_var(g,g%codes(a+i)) + if(iand(flags,op_1_block+op_2_blocks)/=0) then + call bset_push_to_stack(g,bset) + endif + + endif + call vset_augment(g,vset) + + g%local_taints=ior(save_local_taints,g%local_taints) + contains + + subroutine push_block + bset=bset_new(g,0) + g%depth=g%depth+1 + g%cstack(g%depth)=bset + !write(*,*) 'push to ',g%depth + end subroutine push_block + + subroutine pop_block + g%depth=g%depth-1 + g%codes(l+comp_op_line)=bset + !write(*,*) 'pop to',g%depth + end subroutine pop_block + + end subroutine record_vars_for_op + + + !===================================================== + ! Create a variable entry/entries for given argument + !===================================================== + recursive subroutine record_var_access(g,avar,mode) + type(gen_state),intent(inout):: g + integer,intent(in):: avar,mode + integer:: kind,i,j,var + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + if(debug_g) write(*,*) 'RECORD VAR ACCESS> ',var,g_index(g,var),& + g%depth,g%lstack(g%depth)%idx !,g_kind(g,var),g_v1(g,var) + kind=g_kind(g,var) + select case(kind) + case(v_is_group) + do i=1,g_v1(g,var) + call record_var_access(g,g_ptr(g,var,i),mode) + enddo + case(v_is_sub,v_is_vsub) + call record_var_access(g,g_v1(g,var),mode) + call record_var_access(g,g_v2(g,var),mode) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + call record_var_access(g,g_v1(g,var),mode) + case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) + continue + case(v_is_cove) + call record_var_access(g,g_v2(g,var),mode) + case(v_is_alias) + call record_var_access(g,g_v1(g,var),mode) + case(v_is_chan_vect) + call record_var_access(g,g_v1(g,var),mode) + case default + i=g%varindex(var) + call add_var_access(g,i,mode) + do j=g%vardata(i)%depth+1,g%depth + call bset_add(g,g%cstack(j),i,mode) + enddo + end select + end subroutine record_var_access + + !=============================================== + ! Add a variable access to the vset + ! which must be on top of the lower wstack + !=============================================== + subroutine add_var_access(g,var,mode) + type(gen_state),intent(inout):: g + integer,intent(in):: var,mode + if(g%wtop+1>=g%wbot) call grow_wstack(g) + g%wtop=g%wtop+1 + g%wstack(g%wtop)=mode+var*acc_mult + end subroutine add_var_access + + !*********************************************** + ! Loop invariant motion + ! look for operations that only use read-only + ! entries to the loop block (which must + ! be updated as operations are moved) + !*********************************************** + + !=============================================== + ! Apply invariant motion to a block + ! (which may be nested) + !=============================================== + recursive subroutine loop_invar_motion_block(g,blk,& + loop_preop,loop_blk,invar_vset,loop_depth) + type(gen_state),intent(inout):: g + integer,intent(inout):: blk,loop_blk + integer,intent(in):: loop_preop,invar_vset,loop_depth + integer:: p,l + p=0 + l=blk + do while(l>0) + call loop_invar_motion_op(g,l,p,blk,loop_preop,& + loop_blk,invar_vset,loop_depth) + p=l + l=g%codes(l) + enddo + end subroutine loop_invar_motion_block + + !=============================================== + ! Apply invariant motion to an operation + ! moving it if required + !=============================================== + recursive subroutine loop_invar_motion_op(g,& + op,preop,blk,& + loop_preop,loop_blk,invar_vset,loop_depth) + type(gen_state),intent(inout):: g + integer,intent(in):: op,preop,loop_preop,invar_vset,loop_depth + integer,intent(inout):: blk,loop_blk + integer:: i,j,v,a,old_top,old_depth,depth,op_vset,opcode,flags,taints + integer,parameter:: cannot_move=op_is_comm+op_prints_out+op_is_file + opcode=g%codes(op+comp_op_opcode) + flags=op_flags(opcode) + op_vset=g%codes(op+comp_op_line) + taints=vset_taints(g,op_vset) + if(iand(taints,cannot_move)==0) then + if(vset_invar(g,invar_vset,op_vset)) then + do i=1,vset_size(g,op_vset) + call vset_get(g,op_vset,i,v,a) + if(iand(a,acc_write)==0) then + if(iand(a,acc_read)/=0) then + ! Abandon - RW access + return + elseif(iand(g%vardata(v)%flags,var_is_modified)/=0) then + ! Abandon - modified in loop + return + endif + endif + enddo + do i=1,vset_size(g,op_vset) + call vset_get(g,op_vset,i,v,a) + if(iand(a,acc_write)==0) then + call add_var_access(g,v,acc_read) + old_depth=g%vardata(v)%depth + g%vardata(v)%depth=loop_depth + do j=loop_depth,old_depth-1 + call bset_add(g,g%cstack(i),v,acc_read) + enddo + endif + enddo + call vset_augment(g,invar_vset) + call move_op(g,blk,preop,loop_blk,loop_preop) + return + endif + endif + if(iand(flags,op_1_block+op_2_blocks)/=0) then + if(iand(flags,op_has_comm_block+op_has_loop_block)==0) then + if(vset_includes_a_bset_read(g,invar_vset,vset_loc(g,op_vset))) then + call loop_invar_motion_block(g,g%codes(op+comp_op_arg0+1),& + loop_preop,loop_blk,invar_vset,loop_depth) + if(iand(flags,op_2_blocks)/=0) then + call loop_invar_motion_block(g,g%codes(op+comp_op_arg0+2),& + loop_preop,loop_blk,invar_vset,loop_depth) + endif + endif + endif + endif + end subroutine loop_invar_motion_op + + ! ************************************************************* + ! This performs a list scheduling of a block of instructions + ! in a communicating block + ! ************************************************************* + recursive subroutine schedule_comm_block(g,ptr_to_start) + type(gen_state):: g + + ! Relative priorities of each kind of instruction + integer,parameter:: instr_precedes_loop=0 + integer,parameter:: instr_is_comm=1 + integer,parameter:: instr_is_std=2 + integer,parameter:: instr_is_sync_recv=3 + integer,parameter:: instr_is_sync=4 + integer,parameter:: instr_follows_loop=5 + + integer,parameter:: instr_is_shared=16 + integer,parameter:: instr_is_loop_break=32 + integer,parameter:: instr_priority_mask=15 + + type instruction + integer(pm_ln):: bloom,wbloom + integer:: index + integer:: ve,cove + integer:: kind + integer:: taints + integer:: vset + end type instruction + + integer,intent(inout):: ptr_to_start + integer:: ninstr,ll,i,j,k,num_scheduled + integer:: instr_ptr,instr_scheduled + integer:: curr_priority,new_priority + logical:: have_shared,have_non_shared + type(instruction),allocatable,dimension(:):: instr + integer(pm_ln),dimension(:,:,:),allocatable:: mask + integer,allocatable,dimension(:):: nafter + + if(debug_opt) write(*,*) 'SCHEDULE BLOCK>',ptr_to_start + + ninstr=0 + ll=ptr_to_start + do while(ll/=0) + ninstr=ninstr+1 + ll=g%codes(ll) + enddo + + if(ninstr<3) return + + write(72,*) 'Schedule',ninstr + + allocate(instr(ninstr)) + allocate(nafter(ninstr),source=0) + + ! Process each instruction to get information + have_shared=.false. + have_non_shared=.false. + i=0 + ll=ptr_to_start + do while(ll/=0) + i=i+1 + call process_instr(instr(i),ll) + if(iand(instr(i)%kind,instr_is_shared)/=0) have_shared=.true. + if(iand(instr(i)%kind,instr_is_shared)==0) have_non_shared=.true. + ll=g%codes(ll) + enddo + + if(.not.(have_shared.and.have_non_shared)) then + ! No need to schedule + write(72,*) 'No sched',have_shared,have_non_shared + goto 10 + endif + + ! Compute nafter(instr) - number of instructions that must follow instr + ! due to a direct clash (RaW, WaW or WaW conflict) + do i=1,ninstr + do j=1,i-1 + if(conflict(j,i)) nafter(j)=nafter(j)+1 + enddo + enddo + + ! Find last instruction + instr_ptr=0 + j=-1 + curr_priority=-1 + do i=1,ninstr + if(nafter(i)==0) then + new_priority=solo_priority(instr(i)) + if(new_priority>=curr_priority) then + j=i + curr_priority=new_priority + endif + endif + enddo + instr_scheduled=j + call schedule(instr_scheduled) + + ! Schedule remaining instructions + do num_scheduled=2,ninstr + write(72,*) 'Scheduling',num_scheduled + curr_priority=-1 + j=-1 + do i=1,ninstr + if(instr(i)%kind<0) cycle + if(i=curr_priority) then + j=i + curr_priority=new_priority + endif + endif + enddo + instr_scheduled=j + call schedule(instr_scheduled) + write(72,*) 'scheduled',instr_scheduled + if(debug_opt) write(*,*) 'scheduled',num_scheduled,' of ',ninstr + enddo + ptr_to_start=instr_ptr + +10 continue + + deallocate(instr) + deallocate(nafter) + + contains + + subroutine process_instr(instr,l) + type(instruction),intent(inout):: instr + integer,intent(in):: l + integer:: j,opcode,n,a,m,kind,taints,v,acc + opcode=g%codes(l+comp_op_opcode) + if(debug_opt) write(*,*) 'Process instr>',l,op_names(opcode) + n=g%codes(l+comp_op_nargs) + a=l+comp_op_arg0 + instr%index=l + instr%bloom=0 + instr%wbloom=0 + instr%ve=g%codes(a) + if(g%codes(a)>0) then + instr%cove=g_v2(g,g%codes(a)) + else + instr%cove=0 + endif + instr%vset=g%codes(l+comp_op_line) + do j=1,vset_size(g,instr%vset) + call vset_get(g,instr%vset,j,v,acc) + if(acc/=0) then + instr%bloom=bloom(instr%bloom,v) + endif + if(iand(acc,acc_write)/=0) then + instr%wbloom=bloom(instr%wbloom,v) + endif + enddo + taints=vset_taints(g,instr%vset) + instr%taints=taints + kind=instr_is_std + if(iand(taints,op_precedes_loop)/=0) then + kind=instr_precedes_loop + elseif(iand(taints,op_is_sync+op_is_sync_recv+op_is_send+op_is_recv)==op_is_sync) then + kind=instr_is_sync + elseif(iand(taints,op_is_sync_recv+op_is_sync)/=0) then + kind=instr_is_sync_recv + elseif(iand(taints,op_is_send+op_is_recv)/=0) then + kind=instr_is_comm + endif + + instr%kind=kind + end subroutine process_instr + + function bloom(bloom_in,v) result(bloom_out) + integer(pm_ln),intent(in):: bloom_in + integer,intent(in):: v + integer(pm_ln):: bloom_out + bloom_out=ibset(bloom_in,mod(v,bit_size(bloom_in))) + end function bloom + + function conflict(i,j) result(conflicting) + integer,intent(in):: i,j + logical:: conflicting + if(iand(instr(i)%kind,instr_is_loop_break)/=0.and.& + iand(instr(j)%kind,instr_is_shared)==0) then + conflicting=.true. + return + endif + if(iand(iand(instr(i)%taints,instr(j)%taints),& + op_is_comm+op_is_file+op_prints_out)/=0) then + conflicting=.true. + return + endif + if(ior(iand(instr(i)%wbloom,instr(j)%bloom),& + iand(instr(i)%bloom,instr(j)%wbloom))==0) then + conflicting=.false. + return + endif + conflicting=vset_clash(g,instr(i)%vset,instr(j)%vset) + end function conflict + + subroutine schedule(i) + integer,intent(in):: i + integer:: index + if(debug_opt) then + write(*,*) 'Scheduled:',i + write(*,*) op_names(g%codes(instr(i)%index+2)) + endif + index=instr(i)%index + g%codes(index)=instr_ptr + instr_ptr=index + instr(i)%kind=-999 + end subroutine schedule + + ! Priority of instruction considered alone + function solo_priority(i) result(priority) + type(instruction),intent(in):: i + integer:: priority + priority=iand(i%kind,instr_priority_mask+instr_is_shared) + end function solo_priority + + ! Priority of instruction in light of last + ! scheduled instruction + function co_priority(i) result(priority) + type(instruction),intent(in):: i + integer:: priority + priority=0 + if(iand(i%kind,instr_is_shared)==& + iand(instr(instr_scheduled)%kind,instr_is_shared)) then + priority=priority+4 + endif + if(i%ve==instr(instr_scheduled)%ve) then + priority=priority+2 + elseif(i%cove==instr(instr_scheduled)%ve) then + priority=priority+1 + endif + priority=iand(i%kind,instr_priority_mask)+priority*(instr_priority_mask+1) + end function co_priority + + end subroutine schedule_comm_block + + subroutine move_op(g,blk,preop,blk2,preop2) + type(gen_state),intent(inout):: g + integer,intent(in):: preop,preop2 + integer,intent(inout):: blk,blk2 + integer:: op,op2,link + if(preop==0) then + op=blk + elseif(preop>0) then + op=g%codes(preop) + else + op=g%wstack(-preop) + endif + if(preop2==0) then + op2=blk2 + blk2=op + elseif(preop2>0) then + op2=g%codes(preop2) + g%codes(preop2)=op + else + op2=g%wstack(-preop2) + g%wstack(-preop2)=op + endif + if(op>0) then + link=g%codes(op) + g%codes(op)=op2 + else + link=g%wstack(-op) + g%wstack(-op)=op2 + endif + if(preop==0) then + blk=op2 + elseif(preop>0) then + g%codes(preop)=op2 + else + g%wstack(-preop)=op2 + endif + end subroutine move_op + + + !=============================================== + ! Create a new block import/export set + !=============================================== + function bset_new(g,blk) result(bset) + type(gen_state),intent(inout):: g + integer,intent(in):: blk + integer:: bset + integer:: i + if(g%wtop>=g%wbot) call grow_wstack(g) + g%wbot=g%wbot-3 + i=g%wbot + g%wstack(i)=blk + g%wstack(i+1)=0 + g%wstack(i+2)=0 + bset=i-g%wmax + end function bset_new + + !=============================================== + ! Add a variable to a given block import/export + ! set + !=============================================== + subroutine bset_add(g,bset,var,mode) + type(gen_state),intent(inout):: g + integer,intent(in):: bset,var,mode + integer:: head,tail,i + if(debug_g) then + write(*,*) 'Add ',var,' to ',bset + endif + if(g%wtop>=g%wbot) call grow_wstack(g) + head=bset + tail=g%wstack(g%wmax+head+1) + do while(tail/=0.and.g%wstack(g%wmax+tail)/acc_mult' + l=loc + do while(l>0) + if(debug_g) write(*,*) 'DO VAR>',l + g%lstack(g%depth)%idx=g%lstack(g%depth)%idx+1 + call gen_var_op(g,l) + l=g%codes(l) + if(debug_g) write(*,*) 'NEXT VAR',l + enddo + if(debug_g) write(*,*) 'END VAR BLOCK>' + end subroutine gen_var_block + + !============================================================= + ! Assign variables for a block with comm operations + !============================================================= + subroutine gen_var_comm_block(g,blk) + type(gen_state):: g + integer,intent(in):: blk + integer:: save_depth,ll + save_depth=g%depth + if(debug_g) write(*,*) 'VAR COMM BLK>',blk + call g_new_frame(g) + ll=blk + do while(ll>0) + g%lstack(g%depth)%idx=g%lstack(g%depth)%idx+1 + call gen_var_op(g,ll) + ll=g%codes(ll) + enddo + g%depth=save_depth + if(debug_g) write(*,*) 'VAR COMM BLK>',blk + end subroutine gen_var_comm_block + + !============================================================= + ! Assign variables for inline shared proc body + !============================================================= + subroutine gen_var_shared_block(g,blk) + type(gen_state):: g + integer,intent(in):: blk + integer:: save_depth,ll + if(debug_g) write(*,*) 'VAR SHARED BLK>',blk + save_depth=g%depth + call g_new_frame(g) + g%lstack(g%depth)%loop_mode=loop_is_none + ll=blk + do while(ll>0) + g%lstack(g%depth)%idx=g%lstack(g%depth)%idx+1 + call gen_var_op(g,ll) + ll=g%codes(ll) + enddo + call sort_var_list(g) + g%depth=save_depth + if(debug_g) write(*,*) 'END VAR SHARED BLK>',blk + end subroutine gen_var_shared_block + + + !================================================== + ! Assign variables for a single operation + !================================================== + recursive subroutine gen_var_op(g,l) + type(gen_state):: g + integer,intent(in):: l + integer:: opcode,opcode2,n,arg + integer:: i,j,a,save_depth,ll,var1,idx1 + logical:: save_loop_contains_shared + if(pm_debug_level>0) then + if(l>size(g%codes)) then + write(*,*) 'l=',l,size(g%codes) + call pm_panic('gen_var_op bad l') + endif + endif + opcode=g%codes(l+comp_op_opcode) + opcode2=g%codes(l+comp_op_opcode2) + n=iand(g%codes(l+comp_op_nargs),comp_op_nargs_mask) + a=l+comp_op_arg0 + + if(debug_g) then + write(*,*) 'l=',l,n,op_names(opcode) + write(*,*) 'VAR OP> ',g%lstack(g%depth)%idx,l,op_names(opcode),n,& + '>>',g%codes(l:l+comp_op_arg0+n-1) + endif + + select case(opcode) + case(op_if,op_if_shared,op_if_restart) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call gen_var_block(g,g%codes(a+2)) + call use_var(g,g%codes(a+3)) + case(op_if_shared_node) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call gen_var_block(g,g%codes(a+2)) + case(op_over,op_skip_empty) + call cross_all_vars(g) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call cross_all_vars(g) + case(op_head_node) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + case(op_loop) + save_loop_contains_shared=g%loop_contains_shared + g%loop_contains_shared=.false. + var1=g%lstack(g%depth)%varlist + idx1=g%lstack(g%depth)%idx + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call extend_finish_to_loop(g,idx1,g%lstack(g%depth)%idx,var1) + call use_var(g,g%codes(a+2)) + if(g%loop_contains_shared) then + g%codes(l+comp_op_opcode2)=ior(g%codes(l+comp_op_opcode2),2) + endif + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_loop,op_comm_loop_par) + save_loop_contains_shared=g%loop_contains_shared + var1=g%lstack(g%depth)%varlist + idx1=g%lstack(g%depth)%idx + call cross_all_vars(g) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call extend_finish_to_loop(g,idx1,g%lstack(g%depth)%idx,var1) + call use_var(g,g%codes(a+2)) + call cross_all_vars(g) + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_proc) + save_loop_contains_shared=g%loop_contains_shared + call use_var(g,g%codes(a)) + call gen_var_comm_block(g,g%codes(a+1)) + g%loop_contains_shared=save_loop_contains_shared + case(op_inline_shared) + save_loop_contains_shared=g%loop_contains_shared + call use_var(g,g%codes(a)) + call gen_var_shared_block(g,g%codes(a+1)) + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_block) + save_loop_contains_shared=g%loop_contains_shared + call use_var(g,g%codes(a)) + call use_var(g,g%codes(a+2)) + call gen_var_comm_block(g,g%codes(a+1)) + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_call,op_dref,op_wrap) + call cross_all_vars(g) + do i=0,n-1 + call use_var(g,g%codes(a+i)) + call cross_var(g,g%codes(a+i)) + call use_var(g,g%codes(a+i)) + enddo + case(op_init_var) + call use_var(g,g%codes(a)) + call use_var(g,g%codes(a+1)) + case(op_comm_inline) !!! Obsolete? + call cross_all_vars(g) + case(op_sync) + call cross_all_vars(g) + case(op_broadcast_val,& + op_sync_mess,op_break_loop,& + op_read_file_tile,op_write_file_tile,op_broadcast,& + op_broadcast_shared,op_nested_loop,& + op_blocked_loop,op_isend_offset,op_irecv_offset,& + op_recv_offset,op_recv_offset_resend,op_isend_reply,& + op_recv_reply,op_isend_req,op_isend_assn,op_active,op_get_size) + call cross_all_vars(g) + do i=0,n-1 + call use_var(g,g%codes(a+i)) call cross_var(g,g%codes(a+i)) enddo - save_lthis=g%lthis + case(op_remote_send_call,op_collect_call) + call cross_all_vars(g) + call use_var(g,g%codes(a)) + do i=6,n-1 !!! Dont use or cross outputs + call use_var(g,g%codes(a+i)) + call cross_var(g,g%codes(a+i)) + enddo + save_depth=g%depth call g_new_frame(g) call use_var(g,g%codes(a+4)) call cross_var(g,g%codes(a+4)) call use_var(g,g%codes(a+5)) call cross_var(g,g%codes(a+5)) call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis + g%depth=save_depth call gen_var_block(g,g%codes(a+2)) call cross_all_vars(g) call use_var(g,g%codes(a)) @@ -573,14 +1833,14 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+i)) call cross_var(g,g%codes(a+i)) enddo - save_lthis=g%lthis + save_depth=g%depth call g_new_frame(g) call use_var(g,g%codes(a+4)) call cross_var(g,g%codes(a+4)) call use_var(g,g%codes(a+8)) call cross_var(g,g%codes(a+8)) call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis + g%depth=save_depth call gen_var_block(g,g%codes(a+2)) call cross_all_vars(g) call use_var(g,g%codes(a)) @@ -595,14 +1855,14 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+i)) call cross_var(g,g%codes(a+i)) enddo - save_lthis=g%lthis + save_depth=g%depth call g_new_frame(g) call use_var(g,g%codes(a+2)) call cross_var(g,g%codes(a+2)) call use_var(g,g%codes(a+3)) call cross_var(g,g%codes(a+3)) call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis + g%depth=save_depth call cross_all_vars(g) call use_var(g,g%codes(a)) do i=5,n-1 @@ -615,7 +1875,7 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+4)) call cross_var(g,g%codes(a+4)) call cross_all_vars(g) - save_lthis=g%lthis + save_depth=g%depth call g_new_frame(g) call cross_all_vars(g) call use_var(g,g%codes(a+2)) @@ -628,7 +1888,7 @@ recursive subroutine gen_var_op(g,l) endif call gen_var_block(g,g%codes(a+1)) call cross_all_vars(g) - g%lthis=save_lthis + g%depth=save_depth case(op_do_at) call use_var(g,g%codes(a)) if(opcode2==0) then @@ -646,52 +1906,184 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+i)) enddo end select - - if(debug_g) write(*,*) 'END VAR OP> ',l,op_names(opcode) - - end subroutine gen_var_op - - !============================================================= - ! Variable assignment phase for a block with comm operations - !============================================================= - subroutine gen_var_comm_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - save_lthis=g%lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - call g_new_frame(g) - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - g%lthis=save_lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - end subroutine gen_var_comm_block - - !============================================================= - ! Variable assignment phase for inline shared proc body - !============================================================= - subroutine gen_var_shared_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - if(debug_g) write(*,*) 'VAR SHARED BLK>',blk - save_lthis=g%lthis - call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - call sort_var_list(g) - g%lthis=save_lthis - if(debug_g) write(*,*) 'END VAR SHARED BLK>',blk - end subroutine gen_var_shared_block + + if(debug_g) write(*,*) 'END VAR OP> ',l,op_names(opcode) + + end subroutine gen_var_op + + !================================================================= + ! Use a variable - called in variable allocation phase + ! Employs simple state engine to determine how a variable needs + ! to be stored + !================================================================= + recursive subroutine use_var(g,avar,isassign) + type(gen_state),intent(inout):: g + integer,intent(in):: avar + logical,intent(in),optional:: isassign + integer:: kind,state,i,j,var,flags,tno,oldstate + integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& + var_state_used, & ! var_state_unused + var_state_used, & ! var_state_open + var_state_used, & ! var_state_used + var_state_crossing, & ! var_state_used_before + var_state_crossing, & ! var_state_crossing + var_state_used & ! var_state_closed + /) + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + if(debug_g) write(*,*) 'USE VAR> ',var,g_index(g,var),g%depth,g%lstack(g%depth)%idx !,g_kind(g,var),g_v1(g,var) + kind=g_kind(g,var) + select case(kind) + case(v_is_group) + do i=1,g_v1(g,var) + call use_var(g,g_ptr(g,var,i),isassign) + enddo + case(v_is_sub,v_is_vsub) + call use_var(g,g_v1(g,var),isassign) + call use_var(g,g_v2(g,var),isassign) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + call use_var(g,g_v1(g,var),isassign) + case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) + continue + case(v_is_cove) + call use_var(g,g_v2(g,var),isassign) + g%varindex(var)=g%varindex(g_v2(g,var)) + case(v_is_alias) + call use_var(g,g_v1(g,var),isassign) + g%varindex(var)=g%varindex(g_v1(g,var)) + case(v_is_chan_vect) + call use_var(g,g_v1(g,var),isassign) + g%varindex(var)=g%varindex(g_v1(g,var)) + case default + i=g%varindex(var) + if(g%vardata(i)%state==var_state_unused) then + if(kind==v_is_ve) then + call use_var(g,g_v1(g,var)) + endif + flags=g%vardata(i)%flags + if(iand(g%taints,proc_is_comm)/=0.and.& + iand(flags,v_is_param+v_is_result)/=0) then + if(iand(flags,v_is_shared)/=0) then + g%vardata(i)%state=var_state_used + g%vardata(i)%depth=g%depth + else + g%vardata(i)%state=var_state_crossing + if(iand(flags,v_is_result)/=0) then + g%vardata(i)%depth=g%depth + else + g%vardata(i)%depth=g%depth+1 + endif + endif + else + g%vardata(i)%depth=g%depth + g%vardata(i)%state=var_state_used + endif + g%vardata(i)%outer_depth=g%vardata(i)%depth + g%vardata(i)%start=g%lstack(g%depth)%idx + g%vardata(i)%finish=g%vardata(i)%start + if(debug_g) write(*,*) 'START/FINISH=',g%vardata(i)%start + g%vardata(i)%link=g%lstack(g%depth)%varlist + g%lstack(g%depth)%varlist=i + !g%vardata(i)%oindex=var + g%vardata(i)%finish_on_assign=.false. + g%vardata(i)%free=0 + if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link + else + oldstate=g%vardata(i)%state + g%vardata(i)%state=new_state(g%vardata(i)%state) + g%vardata(i)%finish=g%lstack(g%vardata(i)%depth)%idx + if(debug_g) then + write(*,*) 'FINISH=',g%vardata(i)%start,g%vardata(i)%finish,g%vardata(i)%depth + endif + g%vardata(i)%outer_depth=g_common_frame(g,g%vardata(i)%outer_depth,g%depth) + g%vardata(i)%flags=ior(g%vardata(i)%flags,& + merge(var_is_reused,var_is_used,iand(g%vardata(i)%flags,var_is_used)/=0)) + if(debug_g) then + write(*,*) 'CONSIDER>',i,present(isassign) + endif + g%vardata(i)%finish_on_assign=present(isassign) + endif + end select + end subroutine use_var + + !=========================================================== + ! In variable allocation phase - flag all active variables + ! when a comm op is encountered + !============================================================ + subroutine cross_all_vars(g) + type(gen_state),intent(inout):: g + integer:: var + if(g%lstack(g%depth)%loop_mode==loop_is_none) return + g%loop_contains_shared=.true. + if(debug_g) write(*,*) 'CROSS ALL' + var=g%lstack(g%depth)%varlist + do while(var>0) + if(debug_g) write(*,*) 'CROSS',var,'IN CROSS ALL' + call cross_var_at_index(g,var) + var=g%vardata(var)%link + end do + if(debug_g) write(*,*) 'CROSSED ALL' + end subroutine cross_all_vars + + !============================================================ + ! Flag a single variable crossed by comm op + !============================================================ + subroutine cross_var_at_index(g,i) + type(gen_state),intent(inout):: g + integer,intent(in):: i + integer:: state + integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& + var_state_unused, & ! var_state_unused + var_state_open, & ! var_state_open + var_state_used_before, & ! var_state_used + var_state_used_before, & ! var_state_used_before + var_state_crossing, & ! var_state_crossing + var_state_closed & ! var_state_closed + /) + if(g%lstack(g%depth)%loop_mode==loop_is_none) return + if(i==0) return + if(g%vardata(i)%depth/=g%depth) return + if(iand(g%vardata(i)%flags,v_is_shared)/=0) return + state=g%vardata(i)%state + if(debug_g) write(*,*) 'Crossing',i,state,new_state(state) + g%vardata(i)%state=new_state(state) + end subroutine cross_var_at_index + + !================================================================== + ! Mark a variable as crossed (forced -not dependent on prior state) + !================================================================== + recursive subroutine cross_var(g,avar) + type(gen_state),intent(inout):: g + integer,intent(in):: avar + integer:: i,var + if(g%lstack(g%depth)%loop_mode==loop_is_none) return + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + select case(g_kind(g,var)) + case(v_is_group) + do i=1,g_v1(g,var) + call cross_var(g,g_ptr(g,var,i)) + enddo + case(v_is_sub,v_is_vsub) + call cross_var(g,g_v1(g,var)) + call cross_var(g,g_v2(g,var)) + case(v_is_elem,v_is_unit_elem) + call cross_var(g,g_v1(g,var)) + case(v_is_alias) + call cross_var(g,g_v1(g,var)) + case(v_is_const,v_is_ctime_const,v_is_ve,v_is_cove) + continue + case default + i=g%varindex(var) + if(i/=0) then + if(g%vardata(i)%depth==g%depth.and.& + iand(g%vardata(i)%flags,v_is_shared)==0) then + !g%vardata(i)%state=var_state_crossing# + g%vardata(i)%flags=ior(g%vardata(i)%flags,var_is_comm_op_par) + endif + endif + end select + end subroutine cross_var !======================================================================= ! Reverse list of vars (varlist/link) for current loop context @@ -702,21 +2094,21 @@ subroutine sort_var_list(g) type(gen_state):: g integer:: v,v2 integer:: finish,next,nextv - v=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 + v=g%lstack(g%depth)%varlist + g%lstack(g%depth)%varlist=0 + g%lstack(g%depth)%evarlist=0 do while(v>0) nextv=g%vardata(v)%link - g%vardata(v)%link=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=v - v2=g%lstack(g%lthis)%evarlist + g%vardata(v)%link=g%lstack(g%depth)%varlist + g%lstack(g%depth)%varlist=v + v2=g%lstack(g%depth)%evarlist finish=g%vardata(v)%finish if(v2==0) then - g%lstack(g%lthis)%evarlist=v + g%lstack(g%depth)%evarlist=v g%vardata(v)%elink=0 elseif(g%vardata(v2)%finish>=finish) then g%vardata(v)%elink=v2 - g%lstack(g%lthis)%evarlist=v + g%lstack(g%depth)%evarlist=v else do while(g%vardata(v2)%elink>0) next=g%vardata(v2)%elink @@ -731,13 +2123,13 @@ subroutine sort_var_list(g) if(debug_g) then write(*,*) 'REVERSE OUT VARLIST>' - v=g%lstack(g%lthis)%varlist + v=g%lstack(g%depth)%varlist do while(v>0) write(*,*) v,g%vardata(v)%start v=g%vardata(v)%link enddo write(*,*) 'SORT OUT EVARLIST>' - v=g%lstack(g%lthis)%evarlist + v=g%lstack(g%depth)%evarlist do while(v>0) write(*,*) v,g%vardata(v)%finish v=g%vardata(v)%elink @@ -754,9 +2146,9 @@ end subroutine sort_var_list subroutine alloc_var_list(g) type(gen_state):: g integer:: v,e,i - if(debug_g) write(*,*) 'ALLOCATING>',g%lthis - v=g%lstack(g%lthis)%varlist - e=g%lstack(g%lthis)%evarlist + if(debug_g) write(*,*) 'ALLOCATING>',g%depth + v=g%lstack(g%depth)%varlist + e=g%lstack(g%depth)%evarlist do while(v/=0.and.e/=0) i=min(g%vardata(v)%start,g%vardata(e)%finish+1) do while(g%vardata(e)%finish+1==i) @@ -783,7 +2175,7 @@ subroutine alloc_var_list(g) call deallocate_var(g,e) e=g%vardata(e)%elink enddo -!!$ v=g%lstack(g%lthis)%varlist +!!$ v=g%lstack(g%depth)%varlist !!$ do while(v/=0) !!$ write(34,*) g%vardata(v)%index,g_var_at_index_is_a_vect(g,v) !!$ v=g%vardata(v)%link @@ -809,7 +2201,7 @@ subroutine allocate_var(g,v) if(debug_g) write(*,*) 'no storage',tno elseif(tno>pm_string) then if(debug_g) write(*,*) 'Free hash',tno - key(1)=g%lthis + key(1)=g%depth key(2)=isvect key(3)=tno j=pm_ivect_lookup(g%context,g%freehash,key,3) @@ -819,7 +2211,7 @@ subroutine allocate_var(g,v) if(idx/=0) then p%offset=g%vardata(idx)%free call pm_dict_set_val(g%context,g%freehash,j,p) - g%vardata(idx)%gflags=ior(g%vardata(idx)%gflags,var_is_recycled) + g%vardata(idx)%flags=ior(g%vardata(idx)%flags,var_is_recycled) idx=abs(g%vardata(idx)%index) else g%index=g%index+1 @@ -829,11 +2221,11 @@ subroutine allocate_var(g,v) idx=-v endif else - if(debug_g) write(*,*) 'Freelist',tno,g%lstack(g%lthis)%free(isvect,tno) - if(g%lstack(g%lthis)%free(isvect,tno)/=0) then - idx=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=g%vardata(idx)%free - g%vardata(idx)%gflags=ior(g%vardata(idx)%gflags,var_is_recycled) + if(debug_g) write(*,*) 'Freelist',tno,g%lstack(g%depth)%free(isvect,tno) + if(g%lstack(g%depth)%free(isvect,tno)/=0) then + idx=g%lstack(g%depth)%free(isvect,tno) + g%lstack(g%depth)%free(isvect,tno)=g%vardata(idx)%free + g%vardata(idx)%flags=ior(g%vardata(idx)%flags,var_is_recycled) idx=abs(g%vardata(idx)%index) if(debug_g) write(*,*) 'get free',idx else @@ -843,7 +2235,7 @@ subroutine allocate_var(g,v) else idx=0 endif - if(debug_g) write(*,*) 'ALLOCATED>',v,idx,g%lthis + if(debug_g) write(*,*) 'ALLOCATED>',v,idx,g%depth g%vardata(v)%index=idx end subroutine allocate_var @@ -862,10 +2254,10 @@ subroutine deallocate_var(g,v) isvect=merge(2,1,g_var_at_index_is_a_vect(g,v)) if(debug_g) write(*,*) 'Deallocate',v,tno,isvect if(tno<=pm_string) then - g%vardata(v)%free=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=v + g%vardata(v)%free=g%lstack(g%depth)%free(isvect,tno) + g%lstack(g%depth)%free(isvect,tno)=v else - key(1)=g%lthis + key(1)=g%depth key(2)=isvect key(3)=tno j=pm_ivect_lookup(g%context,g%freehash,key,3) @@ -904,7 +2296,7 @@ function merge_vars(g,v,e,i) result(merged) merged=.false. else g%vardata(v)%index=abs(g%vardata(e)%index) - g%vardata(e)%gflags=ior(g%vardata(e)%gflags,var_is_recycled) + g%vardata(e)%flags=ior(g%vardata(e)%flags,var_is_recycled) if(debug_g) then write(*,*) 'MERGED>',g%vardata(v)%index endif @@ -915,202 +2307,6 @@ function merge_vars(g,v,e,i) result(merged) endif end function merge_vars - !================================================================= - ! Use a variable - called in variable allocation phase - ! Employs simple state engine to determine how a variable needs - ! to be stored - !================================================================= - recursive subroutine use_var(g,avar,isassign) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - logical,intent(in),optional:: isassign - integer:: kind,state,i,j,var,flags,tno - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_used, & ! var_state_unused - var_state_used, & ! var_state_open - var_state_used, & ! var_state_used - var_state_crossing, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_used & ! var_state_closed - /) - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - if(debug_g) write(*,*) 'USE VAR> ',var,g_index(g,var),g%lthis,g%lstack(g%lthis)%idx !,g_kind(g,var),g_v1(g,var) - kind=g_kind(g,var) - select case(kind) - case(v_is_group) - do i=1,g_v1(g,var) - call use_var(g,g_ptr(g,var,i),isassign) - enddo - case(v_is_sub,v_is_vsub) - call use_var(g,g_v1(g,var),isassign) - call use_var(g,g_v2(g,var),isassign) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) - call use_var(g,g_v1(g,var),isassign) - !g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) - continue - case(v_is_cove) - call use_var(g,g_v2(g,var),isassign) - g%varindex(var)=g%varindex(g_v2(g,var)) - case(v_is_alias) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_chan_vect) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case default - i=g%varindex(var) - if(i==0) then - g%nvars=g%nvars+1 - if(debug_g) write(*,*) 'CREATE>',var,g%nvars - i=g%nvars - if(kind==v_is_parve) then - g%vardata(i)%tno=pm_logical - flags=v_is_param - g%vardata(i)%name=0 - elseif(kind==v_is_ve) then - call use_var(g,g_v1(g,var)) - g%vardata(i)%tno=pm_logical - flags=0 - g%vardata(i)%name=0 - else - flags=g_v2(g,var) - tno=g_type(g,var) - g%vardata(i)%tno=tno - if(iand(flags,v_is_array_par_vect)==0) then - g%vardata(i)%name=g_v1(g,var) - else - g%vardata(i)%name=0 - endif - endif - g%vardata(i)%flags=flags - if(iand(g%taints,proc_is_comm)/=0.and.& - iand(flags,v_is_param+v_is_result)/=0) then - if(iand(flags,v_is_shared)/=0) then - g%vardata(i)%state=var_state_used - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%state=var_state_crossing - if(iand(flags,v_is_result)/=0) then - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%lthis=g%lthis+1 - endif - endif - else - g%vardata(i)%lthis=g%lthis - g%vardata(i)%state=var_state_used - endif - g%vardata(i)%outer_lthis=g%vardata(i)%lthis - g%vardata(i)%start=g%lstack(g%lthis)%idx - g%vardata(i)%finish=g%vardata(i)%start - if(debug_g) write(*,*) 'START/FINISH=',g%vardata(i)%start - g%vardata(i)%index=0 - g%vardata(i)%link=g%lstack(g%lthis)%varlist - g%vardata(i)%gflags=0 - g%lstack(g%lthis)%varlist=i - g%vardata(i)%oindex=var - g%vardata(i)%finish_on_assign=.false. - g%vardata(i)%free=0 - g%varindex(var)=i - if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link - else - g%vardata(i)%state=new_state(g%vardata(i)%state) - g%vardata(i)%finish=g%lstack(g%vardata(i)%lthis)%idx - if(debug_g) then - write(*,*) 'FINISH=',g%vardata(i)%start,g%vardata(i)%finish,g%vardata(i)%lthis - endif - g%vardata(i)%outer_lthis=g_common_frame(g,g%vardata(i)%outer_lthis,g%lthis) - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,& - merge(var_is_reused,var_is_used,iand(g%vardata(i)%gflags,var_is_used)/=0)) - if(debug_g) then - write(*,*) 'CONSIDER>',i,present(isassign) - endif - g%vardata(i)%finish_on_assign=present(isassign) - endif - end select - end subroutine use_var - - !=========================================================== - ! In variable allocation phase - flag all active variables - ! when a comm op is encountered - !============================================================ - subroutine cross_all_vars(g) - type(gen_state),intent(inout):: g - integer:: var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - g%loop_contains_shared=.true. - if(debug_g) write(*,*) 'CROSS ALL' - var=g%lstack(g%lthis)%varlist - do while(var>0) - if(debug_g) write(*,*) 'CROSS',var,'IN CROSS ALL' - call cross_var_at_index(g,var) - var=g%vardata(var)%link - end do - if(debug_g) write(*,*) 'CROSSED ALL' - end subroutine cross_all_vars - - !============================================================ - ! Flag a single variable crossed by comm op - !============================================================ - subroutine cross_var_at_index(g,i) - type(gen_state),intent(inout):: g - integer,intent(in):: i - integer:: state - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_unused, & ! var_state_unused - var_state_open, & ! var_state_open - var_state_used_before, & ! var_state_used - var_state_used_before, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_closed & ! var_state_closed - /) - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(i==0) return - if(g%vardata(i)%lthis/=g%lthis) return - if(iand(g%vardata(i)%flags,v_is_shared)/=0) return - state=g%vardata(i)%state - if(debug_g) write(*,*) 'Crossing',i,state,new_state(state) - g%vardata(i)%state=new_state(state) - end subroutine cross_var_at_index - - !================================================================== - ! Mark a variable as crossed (forced -not dependent on prior state) - !================================================================== - recursive subroutine cross_var(g,avar) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - integer:: i,var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - select case(g_kind(g,var)) - case(v_is_group) - do i=1,g_v1(g,var) - call cross_var(g,g_ptr(g,var,i)) - enddo - case(v_is_sub,v_is_vsub) - call cross_var(g,g_v1(g,var)) - call cross_var(g,g_v2(g,var)) - case(v_is_elem,v_is_unit_elem) - call cross_var(g,g_v1(g,var)) - case(v_is_alias) - call cross_var(g,g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_ve,v_is_cove) - continue - case default - i=g%varindex(var) - if(i/=0) then - if(g%vardata(i)%lthis==g%lthis.and.& - iand(g%vardata(i)%flags,v_is_shared)==0) then - !g%vardata(i)%state=var_state_crossing# - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,var_is_comm_op_par) - endif - endif - end select - end subroutine cross_var - !============================================================ ! If a variable was created outside of an iterative loop ! then its lifetime must extend at least to the end of that @@ -1123,7 +2319,7 @@ subroutine extend_finish_to_loop(g,loop_start_idx,loop_finish_idx,last_var_befor ! Loop over vars created before loop var=last_var_before_loop do while(var>0) - if(g%vardata(var)%lthis==g%lthis) then + if(g%vardata(var)%depth==g%depth) then if(g%vardata(var)%finish>=loop_start_idx) then g%vardata(var)%finish=loop_finish_idx endif @@ -1162,7 +2358,7 @@ end subroutine gen_block recursive subroutine gen_op(g,loc) type(gen_state):: g integer,intent(in):: loc - integer:: opcode,opcode2,n,a,arg,save_lthis,l,ll,i,j,k,m,tno + integer:: opcode,opcode2,n,a,arg,save_depth,l,ll,i,j,k,m,tno logical:: ok,need_endif if(pm_debug_level>0) then @@ -1197,7 +2393,7 @@ recursive subroutine gen_op(g,loc) endif if(pm_opts%ftn_annotate) then - call out_char_idx(g,'!',merge(1000,0,g%lstack(g%lthis)%loop_active)+g%lthis) + call out_char_idx(g,'!',merge(1000,0,g%lstack(g%depth)%loop_active)+g%depth) call out_new_line(g) endif @@ -1256,7 +2452,7 @@ recursive subroutine gen_op(g,loc) do i=n/2,1,-1 call out_str(g,'DO I') call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) call out_str(g,'=0,-1+') call out_arg(g,g%codes(a+i+n/2),arg_no_index) call out_new_line(g) @@ -1265,41 +2461,41 @@ recursive subroutine gen_op(g,loc) call out_arg(g,g%codes(a+i),0) call out_str(g,'=I') call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) call out_new_line(g) enddo - call out_char_idx(g,'I',g%lthis) + call out_char_idx(g,'I',g%depth) call out_str(g,'=1+') call out_char_idx(g,'I',0) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) do i=2,n/2 call out_char(g,'+') call out_arg(g,g%codes(a+i+n/2-1),0) call out_str(g,'*(I') call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) enddo do i=2,n/2 call out_char(g,')') enddo call out_new_line(g) - g%lstack(g%lthis)%nloops=n/2 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.true. + g%lstack(g%depth)%nloops=n/2 + g%lstack(g%depth)%loop_mode=loop_is_contig + g%lstack(g%depth)%loop_active=.true. case(op_nested_loop) call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+1) - g%lstack(g%lthis)%loop_mode=loop_is_nested + g%lstack(g%depth)%loop_par=g%codes(a+1) + g%lstack(g%depth)%loop_mode=loop_is_nested case(op_blocked_loop) call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+n-1) - g%lstack(g%lthis)%loop_mode=loop_is_nested + g%lstack(g%depth)%loop_par=g%codes(a+n-1) + g%lstack(g%depth)%loop_mode=loop_is_nested call gen_loop(g,l,.false.) do i=1,n-2 call out_arg(g,g%codes(a+i),0) call out_str(g,'=I') call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) call out_new_line(g) enddo case(op_skip_empty) @@ -1346,7 +2542,7 @@ recursive subroutine gen_op(g,loc) call out_ftn_name(g,g_procname(g,opcode2)) endif call out_str(g,'(N') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_char(g,',') if(g%codes(a)>0) then call out_call_arg(g,g%codes(a),arg_no_index+arg_comm_arg) @@ -1403,13 +2599,13 @@ recursive subroutine gen_op(g,loc) case(op_do_at) call gen_loop(g,l,.false.) if(opcode2==1) then - call out_simple(g,'IDO=I$N',n=g%lthis) + call out_simple(g,'IDO=I$N',n=g%depth) else call out_simple(g,'IDO=$2+1',l) endif - i=g_lthis(g,g%codes(a+merge(2,3,opcode2==1))) + i=g_depth(g,g%codes(a+merge(2,3,opcode2==1))) if(i/=0.and.g%lstack(i)%loop_active) then - write(*,*) 'lthis=',g%lthis,'from',g%codes(a+3) + write(*,*) 'depth=',g%depth,'from',g%codes(a+3) call pm_panic('Loop active in op_do_at') endif g%lalt=i @@ -1430,8 +2626,8 @@ recursive subroutine gen_op(g,loc) continue case(op_wrap) ! Save the current loop context for variable - !write(*,*) 'WRAP',g%lthis,'to',g%codes(a+1) - call g_set_v2(g,g%codes(a+1),g%lthis) + !write(*,*) 'WRAP',g%depth,'to',g%codes(a+1) + call g_set_v2(g,g%codes(a+1),g%depth) case(op_sync) call gen_loop(g,l,.true.) @@ -1522,8 +2718,8 @@ recursive subroutine gen_op(g,loc) !call out_line(g,'write(*,*) "ISEND_ASSN"') call out_simple(g,'JNODE=$2',l) if(n>6) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$6,NREQ)',l,n=g%lthis) + call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%depth) + call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$6,NREQ)',l,n=g%depth) call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') call out_line(g,'CALL MPI_ISEND(NREQ,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') call out_line(g,'PM__PUSH_MESSAGE(JMESS)') @@ -1554,8 +2750,8 @@ recursive subroutine gen_op(g,loc) call gen_active_check_start(g,l) call out_simple(g,'JNODE=$2',l) if(n>4) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%lthis) + call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%depth) + call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%depth) call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') call gen_mpi_recv_part(g,g%codes(a+3),'PM__DATA_TAG','RECV',.true.,'RBUFFER%P','1','NREQ',mode_vect) else @@ -1735,7 +2931,7 @@ recursive subroutine gen_op(g,loc) call out_char(g,'(') if(g_is_vect(g,g%codes(a+1))) then call out_str(g,'IJ,I') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_str(g,')=') else call out_str(g,'IJ)=') @@ -1783,10 +2979,10 @@ recursive subroutine gen_op(g,loc) call gen_loop(g,l,.true.) call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) call out_simple(g,'CALL PM__FILE_SET_VIEW($2,JBASE,$#4,N$N,$5,$1,OFFSET)',l,& - n=g%lthis) + n=g%depth) call out_simple(g,'IF($1==0) THEN',l) call out_get_mpi_base_type(g,g_type(g,g%codes(a+5))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,N$N,JTYPE,JN,LNEW)',l,n=g%lthis) + call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,N$N,JTYPE,JN,LNEW)',l,n=g%depth) if(opcode==op_read_file_tile) then call out_simple(g,'CALL MPI_FILE_READ_ALL($2,$#3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) else @@ -1995,12 +3191,12 @@ subroutine gen_over_block(g,l,blk) type(gen_state):: g integer,intent(in):: l,blk type(gloop):: save_loop - save_loop=g%lstack(g%lthis) - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none + save_loop=g%lstack(g%depth) + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_none call gen_block(g,blk) call gen_loop(g,l,.true.) - g%lstack(g%lthis)=save_loop + g%lstack(g%depth)=save_loop end subroutine gen_over_block !============================================================ @@ -2010,20 +3206,20 @@ subroutine gen_comm_block(g,l,lnew,nc) type(gen_state):: g integer,intent(in):: l,lnew character(len=*),intent(in):: nc - integer:: save_lthis,ll,save_last_ve + integer:: save_depth,ll,save_last_ve call gen_loop(g,l,.false.) save_last_ve=g%last_ve g%last_ve=0 g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_contig - if(pm_opts%ftn_annotate) call out_simple(g,'! BLOCK -> $N',n=g%lthis) - if(nc/=' ') call out_simple(g,'N$N='//nc,l,n=g%lthis) + if(pm_opts%ftn_annotate) call out_simple(g,'! BLOCK -> $N',n=g%depth) + if(nc/=' ') call out_simple(g,'N$N='//nc,l,n=g%depth) call gen_vect_alloc(g) - g%lstack(g%lthis)%loop_active=.false. + g%lstack(g%depth)%loop_active=.false. ll=lnew do while(ll>0) call gen_op(g,ll) @@ -2031,8 +3227,8 @@ subroutine gen_comm_block(g,l,lnew,nc) enddo call gen_loop(g,l,.true.) call gen_vect_dealloc(g) - if(pm_opts%ftn_annotate) call out_simple(g,'!ENDBLOCK -> $N',n=g%lthis) - g%lthis=save_lthis + if(pm_opts%ftn_annotate) call out_simple(g,'!ENDBLOCK -> $N',n=g%depth) + g%depth=save_depth g%last_ve=save_last_ve end subroutine gen_comm_block @@ -2040,7 +3236,7 @@ subroutine gen_mpi_recv_call(g,l,lnew,assn) type(gen_state):: g integer,intent(in):: l,lnew logical,intent(in):: assn - integer:: a,save_lthis,ll,save_last_ve + integer:: a,save_depth,ll,save_last_ve a=l+comp_op_arg0 !call out_line(g,'write(*,*) "RECV CALL"') call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') @@ -2052,11 +3248,11 @@ subroutine gen_mpi_recv_call(g,l,lnew,assn) save_last_ve=g%last_ve g%last_ve=0 g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - call out_simple(g,'CALL MPI_RECV(N$N,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,MPI_STATUS_IGNORE,JERRNO)',n=g%lthis) + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_contig + call out_simple(g,'CALL MPI_RECV(N$N,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,MPI_STATUS_IGNORE,JERRNO)',n=g%depth) call gen_vect_alloc(g) call gen_mpi_recv(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) if(assn) then @@ -2076,7 +3272,7 @@ subroutine gen_mpi_recv_call(g,l,lnew,assn) enddo call gen_loop(g,l,.true.) call gen_vect_dealloc(g) - g%lthis=save_lthis + g%depth=save_depth g%last_ve=save_last_ve end subroutine gen_mpi_recv_call @@ -2087,23 +3283,23 @@ end subroutine gen_mpi_recv_call subroutine gen_shared_block(g,l,lnew) type(gen_state):: g integer,intent(in):: l,lnew - integer:: save_lthis,ll,save_last_ve + integer:: save_depth,ll,save_last_ve call gen_loop(g,l,.true.) save_last_ve=g%last_ve g%last_ve=0 g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none - if(pm_opts%ftn_annotate) call out_simple(g,'! SHARED BLOCK -> $N',n=g%lthis) + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_none + if(pm_opts%ftn_annotate) call out_simple(g,'! SHARED BLOCK -> $N',n=g%depth) ll=lnew do while(ll>0) call gen_op(g,ll) ll=g%codes(ll) enddo - if(pm_opts%ftn_annotate) call out_simple(g,'!END SHARED BLOCK -> $N',n=g%lthis) - g%lthis=save_lthis + if(pm_opts%ftn_annotate) call out_simple(g,'!END SHARED BLOCK -> $N',n=g%depth) + g%depth=save_depth g%last_ve=save_last_ve end subroutine gen_shared_block @@ -2114,23 +3310,23 @@ end subroutine gen_shared_block !================================================================ subroutine g_new_frame(g) type(gen_state),intent(inout):: g - integer:: old_lthis - old_lthis=g%lthis + integer:: old_depth + old_depth=g%depth g%ltop=g%ltop+1 - g%lthis=g%ltop - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 - g%lstack(g%lthis)%defer_free=0 - g%lstack(g%lthis)%idx=0 - g%lstack(g%lthis)%free=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.false. - if(g%lthis==0) then - g%lstack(g%lthis)%parent=0 - g%lstack(g%lthis)%depth=0 + g%depth=g%ltop + g%lstack(g%depth)%varlist=0 + g%lstack(g%depth)%evarlist=0 + g%lstack(g%depth)%defer_free=0 + g%lstack(g%depth)%idx=0 + g%lstack(g%depth)%free=0 + g%lstack(g%depth)%loop_mode=loop_is_contig + g%lstack(g%depth)%loop_active=.false. + if(g%depth==0) then + g%lstack(g%depth)%parent=0 + g%lstack(g%depth)%depth=0 else - g%lstack(g%lthis)%parent=old_lthis - g%lstack(g%lthis)%depth=g%lstack(old_lthis)%depth+1 + g%lstack(g%depth)%parent=old_depth + g%lstack(g%depth)%depth=g%lstack(old_depth)%depth+1 endif end subroutine g_new_frame @@ -2138,33 +3334,33 @@ end subroutine g_new_frame ! Given the indices of two loop stack frames, determine the ! index of a third frame that is common parent to both !================================================================ - function g_common_frame(g,lthis_1,lthis_2) result(lthis) + function g_common_frame(g,depth_1,depth_2) result(depth) type(gen_state):: g - integer,intent(in):: lthis_1,lthis_2 - integer:: lthis1,lthis2,lthis - lthis1=lthis_1 - lthis2=lthis_2 - if(lthis1==lthis2) then - lthis=lthis1 + integer,intent(in):: depth_1,depth_2 + integer:: depth1,depth2,depth + depth1=depth_1 + depth2=depth_2 + if(depth1==depth2) then + depth=depth1 return endif - do while(g%lstack(lthis1)%depth>g%lstack(lthis2)%depth) - !write(73,*) '1>',lthis1,g%lstack(lthis1)%depth - lthis1=g%lstack(lthis1)%parent + do while(g%lstack(depth1)%depth>g%lstack(depth2)%depth) + !write(73,*) '1>',depth1,g%lstack(depth1)%depth + depth1=g%lstack(depth1)%parent enddo - do while(g%lstack(lthis2)%depth>g%lstack(lthis1)%depth) - !write(73,*) '2>',lthis2,g%lstack(lthis2)%depth - lthis2=g%lstack(lthis2)%parent + do while(g%lstack(depth2)%depth>g%lstack(depth1)%depth) + !write(73,*) '2>',depth2,g%lstack(depth2)%depth + depth2=g%lstack(depth2)%parent enddo - do while(lthis1/=lthis2.and.lthis1/=0.and.lthis2/=0) - !write(73,*) '12>',lthis1,lthis2,g%lstack(lthis1)%depth - lthis1=g%lstack(lthis1)%parent - lthis2=g%lstack(lthis2)%parent + do while(depth1/=depth2.and.depth1/=0.and.depth2/=0) + !write(73,*) '12>',depth1,depth2,g%lstack(depth1)%depth + depth1=g%lstack(depth1)%parent + depth2=g%lstack(depth2)%parent enddo - !write(73,*) 'F>',lthis1,lthis2 - lthis=lthis1 - !write(73,*) lthis,min(lthis_1,lthis_2) - !if(lthis/=min(lthis_1,lthis_2)) write(73,*)'********' + !write(73,*) 'F>',depth1,depth2 + depth=depth1 + !write(73,*) depth,min(depth_1,depth_2) + !if(depth/=min(depth_1,depth_2)) write(73,*)'********' return end function g_common_frame @@ -2186,7 +3382,7 @@ subroutine gen_loop(g,l,isshared) ! Start up loops if((.not.shared).and.(.not.g_loop_active(g))) then call gen_loop_nest(g) - g%lstack(g%lthis)%loop_active=.true. + g%lstack(g%depth)%loop_active=.true. g%last_ve=0 endif @@ -2210,7 +3406,7 @@ end subroutine gen_loop function g_loop_active(g) result(ok) type(gen_state):: g logical:: ok - ok=g%lstack(g%lthis)%loop_active + ok=g%lstack(g%depth)%loop_active end function g_loop_active !============================================================ @@ -2224,23 +3420,23 @@ subroutine gen_loop_nest(g) if(g_loop_active(g)) return - select case(g%lstack(g%lthis)%loop_mode) + select case(g%lstack(g%depth)%loop_mode) case(loop_is_none) return case(loop_is_contig) call out_str(g,'DO I') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_str(g,'=1,N') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_new_line(g) nloops=1 case(loop_is_nested) - call gen_nested_loop(g,g%lstack(g%lthis)%loop_par,nloops) + call gen_nested_loop(g,g%lstack(g%depth)%loop_par,nloops) case default call pm_panic('gen_loop_nest') end select - g%lstack(g%lthis)%loop_active=.true. - g%lstack(g%lthis)%nloops=nloops + g%lstack(g%depth)%loop_active=.true. + g%lstack(g%depth)%nloops=nloops g%last_ve=0 end subroutine gen_loop_nest @@ -2273,19 +3469,19 @@ subroutine gen_nested_loop(g,v,nloops) case(1) ! single point call out_simple(g,'I$N_$M=$I+1 !!! moo',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) !nloops=nloops+1 case(2) ! range call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_new_line(g) nloops=nloops+1 case(3) ! strided range call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,3),0) @@ -2294,20 +3490,20 @@ subroutine gen_nested_loop(g,v,nloops) case(4) ! map seq call out_simple(g,'DO I$N__$M=1,$I',& - n=i,m=g%lthis,x=g_ptr(g,vdim,2)) + n=i,m=g%depth,x=g_ptr(g,vdim,2)) array=g_ptr(g,vdim,1) if(g_kind(g,array)==v_is_group) then call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,array,1)) + n=i,m=g%depth,x=g_ptr(g,array,1)) else call out_simple(g,'I$N_$M=$I%E1%P(I$N__$M)',& - n=i,m=g%lthis,x=array) + n=i,m=g%depth,x=array) endif nloops=nloops+1 case(5) ! blocked seq call out_simple_part(g,'DO I$N__$M=($I)-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,5),0) call out_str(g,',(') call out_arg(g,g_ptr(g,vdim,2),0) @@ -2315,9 +3511,9 @@ subroutine gen_nested_loop(g,v,nloops) call out_arg(g,g_ptr(g,vdim,3),0) call out_new_line(g) call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple_part(g,'MIN(I$N__$M+($I)-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) + n=i,m=g%depth,x=g_ptr(g,vdim,4)) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,')') call out_new_line(g) @@ -2326,16 +3522,16 @@ subroutine gen_nested_loop(g,v,nloops) else ! Array call out_simple(g,'DO I$N__$M=1,SIZE($I%P)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) nloops=nloops+1 endif else call out_simple(g,'DO I$N__$M=1,SIZE($I%E1%P)',& - n=i,m=g%lthis,x=vdim) + n=i,m=g%depth,x=vdim) call out_simple(g,'I$N_$M=$I%E1%P(I$N__$M)',& - n=i,m=g%lthis,x=vdim) + n=i,m=g%depth,x=vdim) nloops=nloops+1 endif enddo @@ -2352,11 +3548,11 @@ subroutine gen_nested_loop(g,v,nloops) case(1) ! single point call out_simple(g,'I$N_$M=$I+1',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) case(2) ! range call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_simple_part(g,',$I%E$N',x=vblock,n=i) call out_new_line(g) @@ -2364,7 +3560,7 @@ subroutine gen_nested_loop(g,v,nloops) case(3) ! strided range call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,3),0) @@ -2374,7 +3570,7 @@ subroutine gen_nested_loop(g,v,nloops) case(5) ! blocked seq call out_simple_part(g,'DO I$N__$M=$I-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,5),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,2),0) @@ -2382,25 +3578,25 @@ subroutine gen_nested_loop(g,v,nloops) call out_arg(g,g_ptr(g,vdim,3),0) call out_new_line(g) call out_simple_part(g,'IMAX$N__$M=MIN(I$N__$M+$I-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) + n=i,m=g%depth,x=g_ptr(g,vdim,4)) call out_arg(g,g_ptr(g,vdim,2),0) call out_line(g,')') call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),IMAX$N__$M',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple(g,',$I%E$N',x=vblock,n=i) nloops=nloops+2 end select else ! Arrays (split) call out_simple_part(g,'DO I$N___$M=1,SIZE($I%P),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple(g,',$I%E$N',x=vblock,n=i) nloops=nloops+1 endif else ! Array call out_simple_part(g,'DO I$N___$M=1,SIZE($I%E1%P),',& - n=i,m=g%lthis,x=vdim) + n=i,m=g%depth,x=vdim) call out_simple(g,',$I%E$N',x=vblock,n=i) nloops=nloops+1 endif @@ -2418,7 +3614,7 @@ subroutine gen_nested_loop(g,v,nloops) case(2) ! range call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,')') call out_new_line(g) @@ -2426,7 +3622,7 @@ subroutine gen_nested_loop(g,v,nloops) case(3) ! strided range call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N*',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,3),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,2),0) @@ -2437,26 +3633,26 @@ subroutine gen_nested_loop(g,v,nloops) case(5) ! blocked seq call out_simple(g,'DO I$N_$M=I$N__$M,MIN(IMAX$N__$M,I$N__$M+$I%E$N)',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) nloops=nloops+1 end select else ! Array (split) call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,1),0) call out_line(g,'))') call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) endif else ! Array call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,1),0) call out_line(g,'%E1))') call out_simple(g,'I$N_$M=$I%E1(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) endif enddo else @@ -2469,16 +3665,16 @@ subroutine gen_nested_loop(g,v,nloops) ! Calculate combined index vsize=g_ptr(g,v,2) - call out_char_idx(g,'I',g%lthis) + call out_char_idx(g,'I',g%depth) call out_str(g,'=1+') call out_char_idx(g,'I',1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) do i=2,ndim call out_char(g,'+') call out_arg(g,g_ptr(g,vsize,i-1),0) call out_str(g,'*(I') call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) enddo do i=2,ndim call out_char(g,')') @@ -2495,11 +3691,11 @@ subroutine gen_close_loops(g) type(gen_state):: g integer:: i if(g_loop_active(g)) then - do i=1,g%lstack(g%lthis)%nloops + do i=1,g%lstack(g%depth)%nloops call out_line(g,'ENDDO') enddo - g%lstack(g%lthis)%loop_active=.false. - g%lstack(g%lthis)%nloops=0 + g%lstack(g%depth)%loop_active=.false. + g%lstack(g%depth)%nloops=0 endif end subroutine gen_close_loops @@ -2716,11 +3912,11 @@ end subroutine gen_stacked_ve subroutine gen_vect_alloc(g) type(gen_state):: g integer:: v - v=g%lstack(g%lthis)%varlist + v=g%lstack(g%depth)%varlist do while(v>0) if(g_var_at_index_is_a_vect(g,v).and.& iand(g%vardata(v)%flags,v_is_result)==0.and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then + iand(g%vardata(v)%flags,var_is_recycled)==0) then call out_str(g,'IF(ALLOCATED(') call out_var_at_index(g,v) if(iand(g%vardata(v)%flags,v_is_chan)/=0) then @@ -2738,7 +3934,7 @@ subroutine gen_vect_alloc(g) call out_str(g,'%P') endif call out_str(g,'(N') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) if(iand(g%vardata(v)%flags,v_is_ve+v_is_cove)/=0) then call out_str(g,'),SOURCE=.FALSE.)') else @@ -2755,12 +3951,12 @@ end subroutine gen_vect_alloc subroutine gen_vect_dealloc(g) type(gen_state):: g integer:: v,outer - v=g%lstack(g%lthis)%varlist + v=g%lstack(g%depth)%varlist do while(v>0) if(g_var_at_index_is_a_vect(g,v).and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then - outer=g%vardata(v)%outer_lthis - if(outer/=g%vardata(v)%lthis) then + iand(g%vardata(v)%flags,var_is_recycled)==0) then + outer=g%vardata(v)%outer_depth + if(outer/=g%vardata(v)%depth) then g%vardata(v)%elink=g%lstack(outer)%defer_free g%lstack(outer)%defer_free=v else @@ -2774,7 +3970,7 @@ subroutine gen_vect_dealloc(g) endif v=g%vardata(v)%link enddo - v=g%lstack(g%lthis)%defer_free + v=g%lstack(g%depth)%defer_free do while(v>0) call out_str(g,'DEALLOCATE(') call out_var_at_index(g,v) @@ -2800,11 +3996,11 @@ subroutine gen_mpi_remote_call(g,l,issend) type(gen_state):: g integer,intent(in):: l logical,intent(in):: issend - integer:: a,ve,v,lthis + integer:: a,ve,v,depth a=l+comp_op_arg0 ve=g%codes(a) call out_line(g,'PM__REQUEST=3-PM__REQUEST') - call out_simple(g,'I$N=1',n=g%lthis) + call out_simple(g,'I$N=1',n=g%depth) if(.not.issend) then v=g%codes(a+6) endif @@ -2861,8 +4057,8 @@ subroutine gen_mpi_remote_call(g,l,issend) call out_line(g,'DO WHILE(JCOMPLETE.LT.PM__MESSAGE_TOP-1)') call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') call out_line(g,'IF(JRQ.EQ.1)THEN') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) + depth=-1 + call gen_server_block(g,l,issend,1,depth) call out_line(g,'ELSE') call out_line(g,'JCOMPLETE=JCOMPLETE+1') call out_line(g,'IF(JCOMPLETE.LT.PM__MESSAGE_TOP)THEN') @@ -2898,7 +4094,7 @@ subroutine gen_mpi_remote_call(g,l,issend) call out_line(g,'DO') call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') call out_line(g,'IF(JRQ==1)THEN') - call gen_server_block(g,l,issend,1,lthis) + call gen_server_block(g,l,issend,1,depth) call out_line(g,'ELSE') call out_line(g,'IF(JRQ.EQ.2)THEN') call out_line(g,'CALL MPI_CANCEL(PM__MESSAGE_STACK(1),JERRNO)') @@ -2922,14 +4118,14 @@ subroutine gen_mpi_collect_call(g,l,issend) type(gen_state):: g integer,intent(in):: l logical,intent(in):: issend - integer:: a,ve,v,lthis + integer:: a,ve,v,depth a=l+comp_op_arg0 ve=g%codes(a) if(.not.issend) then v=g%codes(a+6) endif if(ve==0) then - call out_simple(g,'NTOT=N$N',l,n=g%lthis) + call out_simple(g,'NTOT=N$N',l,n=g%depth) else call out_simple(g,'NTOT=COUNT($#0)',l) endif @@ -3004,8 +4200,8 @@ subroutine gen_mpi_collect_call(g,l,issend) call out_line(g,'NSIZE=-NSIZE') call out_line(g,'JCOMPLETE=JCOMPLETE+1') call out_line(g,'ENDIF') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) + depth=-1 + call gen_server_block(g,l,issend,1,depth) call out_line(g,'IF(JCOMPLETE.EQ.NNODE-1)EXIT') call out_line(g,& @@ -3025,31 +4221,31 @@ end subroutine gen_mpi_collect_call ! Arg list: ve block [ internal-block ] new-v new-w v w p i ! [ internal-block ] present if extra_arg=1 (instead of 0) !============================================================ - subroutine gen_server_block(g,l,issend,extra_arg,lthis) + subroutine gen_server_block(g,l,issend,extra_arg,depth) type(gen_state):: g integer,intent(in):: l,extra_arg logical,intent(in):: issend - integer,intent(inout):: lthis - integer:: a,save_lthis,save_last_ve,ll + integer,intent(inout):: depth + integer:: a,save_depth,save_last_ve,ll a=l+comp_op_arg0+extra_arg - save_lthis=g%lthis - if(lthis<0) then + save_depth=g%depth + if(depth<0) then g%ltop=g%ltop+1 - g%lthis=g%ltop - lthis=g%lthis + g%depth=g%ltop + depth=g%depth else - g%lthis=lthis + g%depth=depth endif - g%lstack(g%lthis)%nloops=1 + g%lstack(g%depth)%nloops=1 save_last_ve=g%last_ve g%last_ve=0 if(pm_opts%ftn_annotate) then - call out_simple(g,'! BLOCK $N (server)',n=g%lthis) + call out_simple(g,'! BLOCK $N (server)',n=g%depth) endif - call out_simple(g,'N$N=ABS(QRBUFFER%P(1))',n=g%lthis) + call out_simple(g,'N$N=ABS(QRBUFFER%P(1))',n=g%depth) call out_line(g,'NA0=1') call gen_vect_alloc(g) @@ -3071,8 +4267,8 @@ subroutine gen_server_block(g,l,issend,extra_arg,lthis) call out_line(g,'ENDIF') endif - call out_simple(g,'DO I$N=1,N$N ! Start of server block',n=g%lthis) - g%lstack(g%lthis)%loop_active=.true. + call out_simple(g,'DO I$N=1,N$N ! Start of server block',n=g%depth) + g%lstack(g%depth)%loop_active=.true. ll=g%codes(a+1-extra_arg) do while(ll>0) call gen_op(g,ll) @@ -3081,7 +4277,7 @@ subroutine gen_server_block(g,l,issend,extra_arg,lthis) call gen_if_nest(g,g%last_ve,0) call out_line(g,'ENDDO !End of server block') - g%lstack(g%lthis)%loop_active=.false. + g%lstack(g%depth)%loop_active=.false. g%last_ve=0 if(.not.issend) then @@ -3091,14 +4287,14 @@ subroutine gen_server_block(g,l,issend,extra_arg,lthis) call gen_vect_dealloc(g) g%last_ve=save_last_ve - g%lthis=save_lthis + g%depth=save_depth call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& 'JCOMM,JMESS,JERRNO)') call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') if(pm_opts%ftn_annotate) then - call out_simple(g,'! END BLOCK $N (server)',n=g%lthis) + call out_simple(g,'! END BLOCK $N (server)',n=g%depth) endif end subroutine gen_server_block @@ -3116,19 +4312,19 @@ subroutine gen_internal_server_block(g,l,vd,vs,ve) integer:: ll,a a=l+comp_op_arg0 call out_line(g,'DO IX='//vs//','//ve) - call out_char_idx(g,'I',g%lthis) + call out_char_idx(g,'I',g%depth) call out_char(g,'=') call out_line(g,vd) - g%lstack(g%lthis)%nloops=1 - g%lstack(g%lthis)%loop_active=.true. + g%lstack(g%depth)%nloops=1 + g%lstack(g%depth)%loop_active=.true. ll=g%codes(a+2) do while(ll>0) call gen_op(g,ll) ll=g%codes(ll) enddo call out_line(g,'ENDDO') - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_active=.false. + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_active=.false. g%last_ve=0 end subroutine gen_internal_server_block @@ -3139,21 +4335,21 @@ end subroutine gen_internal_server_block subroutine gen_mpi_bcast_call(g,l) type(gen_state),intent(inout):: g integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve + integer:: a,ll,save_depth,save_last_ve a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) + call out_simple(g,'I$N=1',n=g%depth) call out_simple(g,'JNODE=$6',l) - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=N$N',n=g%lthis) + call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=N$N',n=g%depth) call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 save_last_ve=g%last_ve g%last_ve=0 - call out_simple(g,'N$N=NA',n=g%lthis) + call out_simple(g,'N$N=NA',n=g%depth) call out_line(g,'NA0=1') call gen_vect_alloc(g) @@ -3176,7 +4372,7 @@ subroutine gen_mpi_bcast_call(g,l) call gen_vect_dealloc(g) g%last_ve=save_last_ve - g%lthis=save_lthis + g%depth=save_depth end subroutine gen_mpi_bcast_call @@ -3187,21 +4383,21 @@ end subroutine gen_mpi_bcast_call subroutine gen_mpi_masked_bcast_call(g,l) type(gen_state),intent(inout):: g integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve + integer:: a,ll,save_depth,save_last_ve a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) + call out_simple(g,'I$N=1',n=g%depth) call out_simple(g,'JNODE=$6',l) call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=COUNT($#0)',l) call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 save_last_ve=g%last_ve g%last_ve=0 - call out_simple(g,'N$N=NA',n=g%lthis) + call out_simple(g,'N$N=NA',n=g%depth) call gen_vect_alloc(g) @@ -3228,7 +4424,7 @@ subroutine gen_mpi_masked_bcast_call(g,l) call gen_vect_dealloc(g) g%last_ve=save_last_ve - g%lthis=save_lthis + g%depth=save_depth end subroutine gen_mpi_masked_bcast_call @@ -3287,7 +4483,7 @@ recursive subroutine gen_mpi_send(g,v,tag,s,mode,comm) call out_comm_var(g,v,mode) call out_line(g,')') tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call g_add_packable(g,pack_vect,tno) call out_simple_part(g,'CALL PM__PACKVEC$N(NA,',n=tno) @@ -3353,7 +4549,7 @@ subroutine out_comm_var(g,v,mode) integer,intent(in):: v integer,intent(in):: mode !write(*,*) 'v is ',v,g_kind(g,v) - !write(*,*) 'SENDING OUT COMM',mode,g%lthis,g_lthis(g,v) + !write(*,*) 'SENDING OUT COMM',mode,g%depth,g_depth(g,v) call out_arg(g,v,merge(0,arg_no_index,mode==mode_array)) if(mode==mode_array) then call out_str(g,'%E1%P') @@ -3416,7 +4612,7 @@ recursive subroutine gen_mpi_recv(g,v,tag,s,mode,rest,comm) endif case(v_is_basic) tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call out_str(g,'NA=SIZE(') call out_comm_var(g,v,mode) @@ -3560,7 +4756,7 @@ recursive subroutine gen_mpi_bcast(g,v,isshared,array_vect) endif call out_get_mpi_base_type(g,tno) call out_simple(g,& - 'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)',n=g%lthis) + 'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)',n=g%depth) endif call out_str(g,'CALL MPI_BCAST(') call out_arg(g,v,merge(arg_no_index,0,isvec)) @@ -3675,7 +4871,7 @@ recursive subroutine gen_mpi_send_part(g,v,tag,s,dv,dv1,dv2,mode,dvv) case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,& v_is_unit_elem,v_is_const,v_is_ctime_const) tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) if(nonblocking) then @@ -3757,8 +4953,8 @@ recursive subroutine gen_mpi_recv_part(g,v,tag,s,rest,dv,dv1,dv2,mode,dvv) case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) tno=g_type(g,v) if(mode==mode_array) then - !write(*,*) 'tno=',pm_typ_as_string(g%context,tno) - tno=pm_typ_arg(g%context,tno,1) + !write(*,*) 'tno=',pm_type_as_string(g%context,tno) + tno=pm_type_arg(g%context,tno,1) endif if(g_is_complex_type(g,tno)) then if(nonblocking) then @@ -3841,7 +5037,7 @@ recursive subroutine gen_mpi_bcast_part(g,v,isshared,dv,dv1,dv2,mode,dvv) endif case(v_is_basic) tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) call g_add_packable(g,pack_vect_disp,tno) @@ -3952,7 +5148,7 @@ subroutine make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) endif call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A,1_PM__LN,JTYPE_N)',& x=g_ptr(g,offsets,1)) - elseif(pm_typ_kind(g%context,g_type(g,offsets))==pm_typ_is_array) then + elseif(pm_type_kind(g%context,g_type(g,offsets))==pm_type_is_array) then call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A%E1%P,1_PM__LN,JTYPE_N)',& x=offsets) else @@ -3964,13 +5160,13 @@ subroutine make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) call pm_panic('grid_dim incorrect number of entries') endif call out_str(g,'CALL PM__GET_MPI_SUBRANGE_TYPE(JTYPE,') - tv=pm_typ_vect(g%context,g_type(g,grid_dim)) + tv=pm_type_vect(g%context,g_type(g,grid_dim)) do j=2,6 - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,j)),pm_type_has_storage)/=0) then call out_arg(g,g_ptr(g,grid_dim,j),0) call out_char(g,',') else - call out_const(g,pm_typ_val(g%context,pm_tv_arg(tv,j))) + call out_const(g,pm_type_val(g%context,pm_tv_arg(tv,j))) call out_char(g,',') endif enddo @@ -4028,7 +5224,7 @@ recursive subroutine gen_pack(g,v1,v2,m) endif elseif(iand(k2,v_is_poly)/=0) then call out_line(g,'IX=0') - call out_simple(g,'DO I$N=1,N$N',n=g%lthis) + call out_simple(g,'DO I$N=1,N$N',n=g%depth) if(m/=0) call out_simple(g,'IF($I) THEN',x=m) call out_line(g,'IX=IX+1') call out_arg(g,v1,arg_ix_index) @@ -4204,7 +5400,7 @@ subroutine gen_array_vect_pack_to_buffer(g,tno,isdisp) logical:: has_depth type(pm_ptr):: tv integer:: tno1,tno2 - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) tno1=pm_tv_arg(tv,1) tno2=pm_tv_arg(tv,2) call out_new_line(g) @@ -4278,7 +5474,7 @@ subroutine gen_pack_routine(g,tno) integer,dimension(pm_int:pm_string):: counts logical:: hasdepth logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 + recur=iand(pm_type_flags(g%context,tno),pm_type_has_poly)/=0 counts=0 call out_new_line(g) if(recur) call out_str(g,'RECURSIVE ') @@ -4302,9 +5498,9 @@ recursive subroutine outpack(tno,varname,depth) type(pm_ptr):: tv,tlist,telem character(len=5):: ibuffer integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) if(tno>=pm_int.and.tno<=pm_string) then call out_str(g,'PM__BUFFER%SIZEOF(') call out_kind(g,tno) @@ -4319,7 +5515,7 @@ recursive subroutine outpack(tno,varname,depth) call out_char(g,'=') call out_line(g,varname) endif - case(pm_typ_is_array) + case(pm_type_is_array) write(ibuffer,'(i5)') depth+1 ibuffer=adjustl(ibuffer) call out_line(g,'NP'//trim(ibuffer)//'=SIZE('//varname//'%E1%P)') @@ -4328,12 +5524,12 @@ recursive subroutine outpack(tno,varname,depth) call outpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) call out_line(g,'ENDDO') call outpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_typ_is_poly) + case(pm_type_is_poly) call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') call out_line(g,'PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT))=0') call out_str(g,'SELECT TYPE(POLYVAR=>') @@ -4360,10 +5556,10 @@ recursive subroutine outpack(tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) + case(pm_type_is_all,pm_type_is_par_kind,pm_type_is_enveloped,& + pm_type_is_vect) call outpack(pm_tv_arg(tv,1),varname,depth) end select end subroutine outpack @@ -4376,7 +5572,7 @@ subroutine gen_unpack_routine(g,tno) type(gen_state):: g integer,intent(in):: tno logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 + recur=iand(pm_type_flags(g%context,tno),pm_type_has_poly)/=0 if(recur) call out_str(g,'RECURSIVE ') call out_str(g,'SUBROUTINE PM__UNPACK') call out_idx(g,tno) @@ -4395,9 +5591,9 @@ recursive subroutine declare_poly_vars(tno) integer,intent(in):: tno type(pm_ptr):: tv,tlist,telem integer:: tno2,i,n - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_poly) + case(pm_type_is_poly) tlist=g_check_poly(g,tno) if(.not.pm_fast_isnull(tlist)) then n=pm_set_size(g%context,tlist) @@ -4414,8 +5610,8 @@ recursive subroutine declare_poly_vars(tno) call out_new_line(g) enddo endif - case(pm_typ_is_array,& - pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_array,& + pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) call declare_poly_vars(pm_tv_arg(tv,i)) enddo @@ -4429,9 +5625,9 @@ recursive subroutine outunpack(tno,varname,depth) type(pm_ptr):: tv,tlist,telem character(len=5):: ibuffer integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) if(tno>=pm_int.and.tno<=pm_string) then call out_str(g,'PM__BUFFER%SIZEOF(') call out_kind(g,tno) @@ -4445,7 +5641,7 @@ recursive subroutine outunpack(tno,varname,depth) call out_kind(g,tno) call out_line(g,'))') endif - case(pm_typ_is_array) + case(pm_type_is_array) write(ibuffer,'(i5)') depth+1 ibuffer=adjustl(ibuffer) call outunpack(int(pm_long),'NP'//trim(ibuffer),depth) @@ -4455,12 +5651,12 @@ recursive subroutine outunpack(tno,varname,depth) call outunpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) call out_line(g,'ENDDO') call outunpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outunpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_typ_is_poly) + case(pm_type_is_poly) call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') call out_line(g,'SELECT CASE(PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT)))') tlist=g_check_poly(g,tno) @@ -4484,10 +5680,10 @@ recursive subroutine outunpack(tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) + case(pm_type_is_all,pm_type_is_par_kind,pm_type_is_enveloped,& + pm_type_is_vect) call outunpack(pm_tv_arg(tv,1),varname,depth) end select end subroutine outunpack @@ -4505,7 +5701,7 @@ subroutine gen_count_routine(g,tno) integer(pm_ln),dimension(pm_int:pm_string):: counts logical:: has_depth logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 + recur=iand(pm_type_flags(g%context,tno),pm_type_has_poly)/=0 if(recur) call out_str(g,'RECURSIVE ') call out_str(g,'SUBROUTINE PM__COUNT') call out_idx(g,tno) @@ -4539,33 +5735,33 @@ recursive subroutine precount(g,tno,counts,has_depth) type(pm_ptr):: tv,val integer:: i integer(pm_ln):: n - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) if(tno>=pm_int.and.tno<=pm_string) then counts(tno)=counts(tno)+1 endif - case(pm_typ_is_array) + case(pm_type_is_array) has_depth2=.false. call precount(g,pm_tv_arg(tv,2),counts,has_depth2) if(pm_tv_arg(tv,3)/=pm_long.and..not.has_depth2) then call precount(g,pm_tv_arg(tv,1),counts2,has_depth) if(.not.has_depth) then - val=pm_typ_val(g%context,pm_tv_arg(tv,3)) + val=pm_type_val(g%context,pm_tv_arg(tv,3)) counts=counts+counts2*val%data%ln(val%offset) endif else has_depth=.true. endif counts(pm_long)=counts(pm_long)+1 - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) call precount(g,pm_tv_arg(tv,i),counts,has_depth) enddo - case(pm_typ_is_poly) + case(pm_type_is_poly) counts(pm_int)=counts(pm_int)+1 has_depth=.true. - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue case default call pm_panic("precount") @@ -4611,11 +5807,11 @@ recursive subroutine outcount(g,tno,varname,depth) character(len=5):: ibuffer integer(pm_ln),dimension(pm_int:pm_string):: counts logical:: has_depth - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) continue - case(pm_typ_is_array) + case(pm_type_is_array) call outcount(g,pm_tv_arg(tv,2),varname//'%E2',depth) has_depth=.false. counts=0 @@ -4631,7 +5827,7 @@ recursive subroutine outcount(g,tno,varname,depth) call get_vect_size(varname) endif call outaddcount(g,counts,depth+1) - case(pm_typ_is_poly) + case(pm_type_is_poly) call out_line(g,'SELECT TYPE(POLYVAR=>'//varname//'%P)') tlist=g_check_poly(g,tno) if(.not.pm_fast_isnull(tlist)) then @@ -4654,15 +5850,15 @@ recursive subroutine outcount(g,tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outcount(g,pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) + case(pm_type_is_all,pm_type_is_par_kind,pm_type_is_enveloped,& + pm_type_is_vect) call outcount(g,pm_tv_arg(tv,1),varname,depth) end select contains @@ -4698,12 +5894,12 @@ subroutine gen_mpi_types(g) do i=0,size-1 key=keys%data%ptr(keys%offset+i) typ=abs(key%data%i(key%offset)) - !write(*,*) 'TYPE #',i,' ',trim(pm_typ_as_string(g%context,typ)) + !write(*,*) 'TYPE #',i,' ',trim(pm_type_as_string(g%context,typ)) call out_type(g,typ) call out_str(g,'::T') call out_idx(g,typ) call out_line(g,'(2)') - tv=pm_typ_vect(g%context,typ) + tv=pm_type_vect(g%context,typ) maxargs=max(maxargs,pm_tv_numargs(tv)) enddo call out_simple(g,'INTEGER,DIMENSION($N):: DATATYPES,BLOCKLENGTHS',n=maxargs) @@ -4715,16 +5911,16 @@ subroutine gen_mpi_types(g) do i=0,size-1 key=keys%data%ptr(keys%offset+i) typ=abs(key%data%i(key%offset)) - call out_comment_line(g,pm_typ_as_string(g%context,typ)) + call out_comment_line(g,pm_type_as_string(g%context,typ)) if(debug_g) then - write(*,*) 'MPI TYP>',pm_typ_as_string(g%context,typ) + write(*,*) 'MPI TYP>',pm_type_as_string(g%context,typ) endif - tv=pm_typ_vect(g%context,typ) + tv=pm_type_vect(g%context,typ) n=pm_tv_numargs(tv) nn=0 do j=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,j)),& + pm_type_has_storage)/=0) then call out_simple(g,'CALL MPI_GET_ADDRESS(T$N(1)%E$M,OFFSETS($M),JERROR)',& n=typ,m=j) nn=nn+1 @@ -4737,7 +5933,7 @@ subroutine gen_mpi_types(g) call out_line(g,'EXTENT=EXTENT-OFFSETS(1)') call out_line(g,'OFFSETS(1)=0') do j=1,nn - call out_comment_line(g,pm_typ_as_string(g%context,pm_tv_arg(tv,j))) + call out_comment_line(g,pm_type_as_string(g%context,pm_tv_arg(tv,j))) call out_get_mpi_base_type(g,pm_tv_arg(tv,j)) call out_simple(g,'DATATYPES($N)=JBASE',n=j) enddo @@ -4781,21 +5977,21 @@ subroutine out_var_def(g,i,iscomm) flags=g%vardata(i)%flags ix=abs(g%vardata(i)%index) - if(iand(g%vardata(i)%gflags,var_is_recycled)/=0) then + if(iand(g%vardata(i)%flags,var_is_recycled)/=0) then return endif oindex=g%vardata(i)%oindex if(debug_g) then - write(*,*) 'VAR>>',i,oindex,' ',trim(pm_typ_as_string(g%context,g%vardata(i)%tno)) + write(*,*) 'VAR>>',i,oindex,' ',trim(pm_type_as_string(g%context,g%vardata(i)%tno)) endif !!$ if(g_kind(g,oindex)==v_is_basic) call out_simple(g,'!'//& !!$ trim(pm_name_as_string(g%context,g_v1(g,oindex)))) -!!$ call out_simple_part(g,'! idx=$N / lthis=$M '//& -!!$ trim(pm_typ_as_string(g%context,g%vardata(i)%tno)),& -!!$ n=g%vardata(i)%oindex,m=g%vardata(i)%lthis) +!!$ call out_simple_part(g,'! idx=$N / depth=$M '//& +!!$ trim(pm_type_as_string(g%context,g%vardata(i)%tno)),& +!!$ n=g%vardata(i)%oindex,m=g%vardata(i)%depth) !!$ call out_simple_part(g,'/ flags=$N state=$M',n=g%vardata(i)%flags,m=g%vardata(i)%state) !!$ call out_simple_part(g,'/ start=$N finish=$M',n=g%vardata(i)%start,m=g%vardata(i)%finish) !!$ call out_simple(g,'/ end_assign=$N',n=merge(1,0,g%vardata(i)%finish_on_assign)) @@ -4846,7 +6042,7 @@ subroutine out_var_def(g,i,iscomm) call out_str(g,'::') call out_var_name_at_index(g,i) - call out_str(g,' ! '//trim(pm_typ_as_string(g%context,g%vardata(i)%tno))) + call out_str(g,' ! '//trim(pm_type_as_string(g%context,g%vardata(i)%tno))) if(pm_opts%ftn_annotate) then call out_simple_part(g,' idx=$N', n=oindex) @@ -4886,10 +6082,10 @@ subroutine out_type_def(g,tno,dim) type(pm_ptr):: tv,val integer:: i,n,k if(tno==0) return - if(iand(pm_typ_flags(g%context,tno),& - pm_typ_has_storage)==0) return + if(iand(pm_type_flags(g%context,tno),& + pm_type_has_storage)==0) return if(dim>0) then - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) + call out_comment_line(g,trim(pm_type_as_string(g%context,tno))) call out_str(g,'TYPE PM__TV') call out_idx(g,tno) call out_char_idx(g,'_',dim) @@ -4898,7 +6094,7 @@ subroutine out_type_def(g,tno,dim) if(dim==pm_long) then call out_line(g,',DIMENSION(:),ALLOCATABLE::P') else - val=pm_typ_val(g%context,dim) + val=pm_type_val(g%context,dim) call out_str(g,',DIMENSION(') call out_const(g,val) call out_line(g,')::P') @@ -4910,34 +6106,34 @@ subroutine out_type_def(g,tno,dim) return endif call out_char(g,'!') - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) + call out_comment_line(g,trim(pm_type_as_string(g%context,tno))) call out_str(g,'TYPE PM__T') call out_idx(g,tno) call out_new_line(g) !call out_line(g,',SEQUENTIAL') - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) n=pm_tv_numargs(tv) k=pm_tv_kind(tv) - if(k==pm_typ_is_array) then + if(k==pm_type_is_array) then call out_str(g,'TYPE(PM__TV') - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,1)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,1)),& + pm_type_has_storage)/=0) then call out_type_idx(g,pm_tv_arg(tv,1)) call out_char(g,'_') call out_type_idx(g,pm_tv_arg(tv,3)) call out_line(g,')::E1') endif - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,2)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,2)),& + pm_type_has_storage)/=0) then call out_type(g,pm_tv_arg(tv,2)) call out_line(g,'::E2') endif - elseif(k==pm_typ_is_vect) then + elseif(k==pm_type_is_vect) then continue else do i=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,i)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,i)),& + pm_type_has_storage)/=0) then call out_type(g,pm_tv_arg(tv,i)) call out_str(g,'::E') call out_idx(g,i) @@ -4957,7 +6153,7 @@ end subroutine out_type_def subroutine out_type_idx(g,tno) type(gen_state):: g integer,intent(in):: tno - if(pm_typ_kind(g%context,tno)==pm_typ_is_poly) then + if(pm_type_kind(g%context,tno)==pm_type_is_poly) then call out_idx(g,int(pm_pointer)) else call out_idx(g,tno) @@ -5135,7 +6331,7 @@ recursive subroutine out_call_arg(g,avar,opts) case(v_is_dref,v_is_shared_dref) n=g_v1(g,var) if(iand(opts,arg_wrapped)/=0) then - tv=pm_typ_vect(g%context,g_type(g,var)) + tv=pm_type_vect(g%context,g_type(g,var)) call out_dref_vect_arg(g,g_ptr(g,var,1),pm_tv_arg(tv,1),opts) call out_comma(g) call out_call_arg(g,g_ptr(g,var,2),opts) @@ -5171,13 +6367,13 @@ recursive subroutine out_call_arg(g,avar,opts) call out_call_arg(g,g_v1(g,var),opts) case default tno=g_type(g,var) - if(pm_typ_kind(g%context,tno)==pm_typ_is_array) then - tv=pm_typ_vect(g%context,tno) - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,1)),pm_typ_has_storage)/=0) then + if(pm_type_kind(g%context,tno)==pm_type_is_array) then + tv=pm_type_vect(g%context,tno) + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,1)),pm_type_has_storage)/=0) then call out_arg(g,var,opts) call out_str(g,'%E1,') endif - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,2)),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,2)),pm_type_has_storage)/=0) then call out_arg(g,var,opts) call out_str(g,'%E2') endif @@ -5195,7 +6391,7 @@ end subroutine out_call_arg recursive subroutine out_dref_vect_arg(g,var,tno,opts) type(gen_state):: g integer,intent(in):: var,tno,opts - if(pm_typ_get_mode(g%context,tno)>=sym_mirrored) then + if(pm_type_get_mode(g%context,tno)>=sym_mirrored) then call out_call_arg(g,var,opts) else call out_call_arg(g,var,ior(opts,arg_wrapped)) @@ -5308,20 +6504,20 @@ end subroutine out_arg_name subroutine out_loop_index(g,v,opt) type(gen_state):: g integer,intent(in):: v,opt - integer:: i,lthis + integer:: i,depth if(g_is_a_vect(g,v)) then - lthis=g_lthis(g,v) + depth=g_depth(g,v) if(iand(opt,arg_ix_index)/=0.and.g_is_vect(g,v)) then call out_str(g,'(IX)') - elseif(iand(opt,arg_no_index+arg_wrapped)==0.or.lthis/=g%lthis.and.iand(opt,arg_wrapped)==0) then - if(lthis==g%lalt) then + elseif(iand(opt,arg_no_index+arg_wrapped)==0.or.depth/=g%depth.and.iand(opt,arg_wrapped)==0) then + if(depth==g%lalt) then call out_str(g,'(IDO)') - elseif(.not.g%lstack(lthis)%loop_active.or.lthis==0) then + elseif(.not.g%lstack(depth)%loop_active.or.depth==0) then call out_str(g,'(1)') else call out_char(g,'(') - call out_char_idx(g,'I',lthis) + call out_char_idx(g,'I',depth) call out_char(g,')') endif endif @@ -5446,7 +6642,7 @@ subroutine out_type(g,typ) integer,intent(in):: typ type(pm_ptr):: tv integer:: tno - tno=pm_typ_strip_to_basic(g%context,typ) + tno=pm_type_strip_to_basic(g%context,typ) select case(tno) case(pm_int) call out_str(g,'INTEGER') @@ -5479,8 +6675,8 @@ subroutine out_type(g,typ) case(pm_pointer,pm_poly_type) call out_str(g,'TYPE(PM__POLY)') case default - tv=pm_typ_vect(g%context,tno) - if(pm_tv_kind(tv)==pm_typ_is_poly) then + tv=pm_type_vect(g%context,tno) + if(pm_tv_kind(tv)==pm_type_is_poly) then call out_str(g,'TYPE(PM__POLY)') else call out_str(g,'TYPE(PM__T') @@ -5609,23 +6805,23 @@ recursive function add_mpi_type(g,typ) result(j) type(pm_ptr):: tv integer:: i,tno if(debug_g) then - write(*,*) 'ADD MPI TYPE',trim(pm_typ_as_string(g%context,typ)) + write(*,*) 'ADD MPI TYPE',trim(pm_type_as_string(g%context,typ)) endif - tno=pm_typ_strip_to_basic(g%context,typ) + tno=pm_type_strip_to_basic(g%context,typ) if(tno<=pm_string) return j=check_set(tno) if(j>0) return j=add_to_root_set(tno) - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_struct,pm_typ_is_rec) + case(pm_type_is_struct,pm_type_is_rec) do i=1,pm_tv_numargs(tv) j=add_mpi_type(g,pm_tv_arg(tv,i)) enddo j=add_to_set(tno) - case(pm_typ_is_poly) + case(pm_type_is_poly) call pm_panic('add_mpi_type: poly type') - case(pm_typ_is_array) + case(pm_type_is_array) if(pm_tv_arg(tv,3)==pm_long) then call pm_panic('add_mpi_type: var length array') else @@ -5634,7 +6830,7 @@ recursive function add_mpi_type(g,typ) result(j) j=add_to_set(tno) endif case default - write(*,*) 'Type',pm_typ_as_string(g%context,tno),' kind ',pm_tv_kind(tv) + write(*,*) 'Type',pm_type_as_string(g%context,tno),' kind ',pm_tv_kind(tv) call pm_panic('add_mpi_type') j=0 end select @@ -6011,7 +7207,7 @@ function g_var_at_index_is_a_vect(g,i) result(ok) logical:: ok integer:: flags,gflags flags=g%vardata(i)%flags - gflags=g%vardata(i)%gflags + gflags=g%vardata(i)%flags ok=(g%vardata(i)%state==var_state_crossing.and.& iand(flags,v_is_par)==0.or.& iand(gflags,var_is_comm_op_par)/=0).and.& @@ -6050,7 +7246,7 @@ function g_is_vect(g,n) result(ok) ok=g_kind(g,n)==v_is_chan_vect else ok=g_is_a_vect(g,n).and.& - (g%vardata(i)%lthis==g%lthis.or.& + (g%vardata(i)%depth==g%depth.or.& iand(g%vardata(i)%flags,v_is_vect)/=0.or.& iand(g%vardata(i)%flags,v_is_in_dref+v_is_shared)==v_is_in_dref) endif @@ -6072,44 +7268,44 @@ end function g_index !============================================= ! Parallel nesting depth of a variable !============================================= - function g_lthis(g,n) result(lthis) + function g_depth(g,n) result(depth) type(gen_state),intent(inout):: g integer,intent(in):: n - integer:: lthis + integer:: depth integer:: i i=g%varindex(abs(n)) if(i==0) then - lthis=get_lthis(abs(n)) - if(lthis<0) then - call pm_panic('g_lthis') + depth=get_depth(abs(n)) + if(depth<0) then + call pm_panic('g_depth') endif else - lthis=g%vardata(i)%lthis + depth=g%vardata(i)%depth endif contains - recursive function get_lthis(n) result(lthis) + recursive function get_depth(n) result(depth) integer,intent(in)::n - integer:: lthis + integer:: depth integer:: i select case(g_kind(g,n)) case(v_is_alias,v_is_elem,v_is_chan_vect,& v_is_unit_elem,v_is_vect_wrapped) - lthis=get_lthis(g_v1(g,n)) + depth=get_depth(g_v1(g,n)) case(v_is_sub,v_is_vsub) - lthis=max(get_lthis(g_v1(g,n)),get_lthis(g_v2(g,n))) + depth=max(get_depth(g_v1(g,n)),get_depth(g_v2(g,n))) case(v_is_group) - lthis=-1 + depth=-1 do i=1,g_v1(g,n) - lthis=max(lthis,get_lthis(g_ptr(g,n,i))) + depth=max(depth,get_depth(g_ptr(g,n,i))) enddo case(v_is_basic) i=g%varindex(abs(n)) - lthis=g%vardata(i)%lthis + depth=g%vardata(i)%depth case default - lthis=-1 + depth=-1 end select - end function get_lthis - end function g_lthis + end function get_depth + end function g_depth !============================================= ! Does variable v have all shared elements @@ -6154,7 +7350,7 @@ function g_var_is_dead(g,n) result(ok) else ok=g%vardata(i)%start==g%vardata(i)%finish.and.& iand(g%vardata(i)%flags,v_is_result)==0.and.& - g%vardata(i)%outer_lthis==g%vardata(i)%lthis + g%vardata(i)%outer_depth==g%vardata(i)%depth if(ok) write(*,*) '>>>>',i,g%vardata(i)%start,g%vardata(i)%finish endif end function g_var_is_dead @@ -6202,7 +7398,7 @@ function g_this_n_str(g) result(str) type(gen_state):: g character(len=6):: str str(1:1)='N' - write(str(2:),'(I5)') g%lthis + write(str(2:),'(I5)') g%depth str(2:)=adjustl(str(2:)) end function g_this_n_str @@ -6252,7 +7448,7 @@ function g_gflags_set(g,v,flags) result(ok) integer:: i if(v/=0) then i=g%varindex(abs(v)) - ok=iand(g%vardata(i)%gflags,flags)==flags + ok=iand(g%vardata(i)%flags,flags)==flags else ok=.false. endif @@ -6268,7 +7464,7 @@ function g_gflags_clear(g,v,flags) result(ok) integer:: i if(v/=0) then i=g%varindex(abs(v)) - ok=iand(g%vardata(i)%gflags,flags)==0 + ok=iand(g%vardata(i)%flags,flags)==0 else ok=.false. endif @@ -6283,7 +7479,7 @@ subroutine g_set_gflags(g,v,flags) integer:: i if(v/=0) then i=g%varindex(abs(v)) - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,flags) + g%vardata(i)%flags=ior(g%vardata(i)%flags,flags) endif end subroutine g_set_gflags @@ -6296,7 +7492,7 @@ subroutine g_clear_gflags(g,v,flags) integer:: i if(v/=0) then i=g%varindex(abs(v)) - g%vardata(i)%gflags=iand(g%vardata(i)%gflags,not(flags)) + g%vardata(i)%flags=iand(g%vardata(i)%flags,not(flags)) endif end subroutine g_clear_gflags @@ -6328,9 +7524,11 @@ function g_is_complex_type(g,tno) result(ok) integer,intent(in):: tno logical:: ok ok=tno==pm_pointer.or.& - iand(pm_typ_flags(g%context,tno),pm_typ_has_array+pm_typ_has_poly)/=0 + iand(pm_type_flags(g%context,tno),pm_type_has_array+pm_type_has_poly)/=0 end function g_is_complex_type + + ! ========================================= ! Placefiller - not needed for compiler ! ========================================= diff --git a/src/codegen.f90 b/src/codegen.f90 index 6592087..af45350 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -90,8 +90,8 @@ module pm_codegen integer,parameter:: cnode_is_resolved_proc=8 integer,parameter:: cnode_is_arg_constraint=9 integer,parameter:: cnode_is_par_constraint=10 - integer,parameter:: cnode_is_typ_constraint=11 - integer,parameter:: cnode_is_interface_constraint=12 + integer,parameter:: cnode_is_type_constraint=11 + !integer,parameter:: cnode_is_interface_constraint=12 integer,parameter:: cnode_is_any_sig=13 integer,parameter:: cnode_is_autoconv_sig=14 integer,parameter:: cnode_num_kinds=14 @@ -261,10 +261,8 @@ module pm_codegen type(pm_ptr):: visibility ! Stack for local variables (stack() for names, var() for info records) - ! Fixed size hash table to search variable names (chained using link()) - integer,dimension(max_code_stack):: stack,link + integer,dimension(max_code_stack):: stack type(pm_ptr),dimension(max_code_stack):: var - integer,dimension(code_local_hash):: hash integer:: top ! Stack of values for creating cnodes @@ -363,7 +361,6 @@ subroutine init_coder(context,coder,visibility) coder%top=1 coder%vtop=0 coder%wtop=0 - coder%hash=0 coder%reg=>pm_register(context,'coder-var stack',coder%temp,coder%temp2,& coder%sig_cache,coder%proc_cache,coder%true,coder%false,coder%one,& coder%undef_val,& @@ -379,7 +376,6 @@ subroutine init_coder(context,coder,visibility) coder%prog_cblock=pm_null_obj coder%defer_check=pm_null_obj coder%proc_base=1 - coder%link(coder%proc_base)=0 coder%proc_ncalls=0 coder%par_base=0 coder%over_base=0 @@ -398,7 +394,7 @@ subroutine init_coder(context,coder,visibility) coder%one=pm_new_small(context,pm_long,1_pm_p) coder%one%data%ln(coder%one%offset)=1 - coder%unit_type=pm_new_value_typ(coder%context,coder%one) + coder%unit_type=pm_new_value_type(coder%context,coder%one) coder%one=pm_new_small(context,pm_int,1_pm_p) coder%one%data%i(coder%one%offset)=1 @@ -412,8 +408,8 @@ subroutine init_coder(context,coder,visibility) coder%check_mess=pm_new_string(coder%context,'Failed "check" or "test""') coder%proc_name_vals=pm_dict_new(coder%context,8_pm_ln) coder%id=0 - coder%true_name=pm_new_value_typ(coder%context,coder%true) - coder%false_name=pm_new_value_typ(coder%context,coder%false) + coder%true_name=pm_new_value_type(coder%context,coder%true) + coder%false_name=pm_new_value_type(coder%context,coder%false) coder%default_label=pm_fast_name(coder%context,sym_pct) coder%label=coder%default_label @@ -431,7 +427,7 @@ subroutine init_coder(context,coder,visibility) function name_type(n) result(u) integer,intent(in):: n integer:: u - u=pm_new_name_typ(coder%context,n) + u=pm_new_name_type(coder%context,n) end function name_type end subroutine init_coder @@ -554,7 +550,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif - call resolve_if_inits(coder,node) call make_sp_call(coder,cblock,node,& sym_if,3,0) coder%par_state=save_par_state @@ -574,7 +569,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif - call resolve_if_inits(coder,node) call make_sp_call(coder,cblock,node,sym,3,0) case(sym_switch) save_par_state=coder%par_state @@ -673,7 +667,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& p=node_arg(node,1) call trav_call(coder,cblock,node,p,0,.true.) case(sym_var,sym_const) - call trav_var_no_init(coder,cblock,list,node) + ! No init var/const case(sym_with) base=coder%top call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) @@ -952,7 +946,7 @@ subroutine apply_x(nodep,node) case(sym_list) call trav_exprlist(coder,cblock,nodep,node) case(sym_result) - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) do i=1,node_numargs(node),2 call trav_expr(coder,cblock,node,node_arg(node,i)) @@ -1056,7 +1050,6 @@ recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) call trav_switch_stmt(coder,cblock2,stmt,idx+2,var,sym) call close_cblock(coder,cblock2) endif - call resolve_if_inits(coder,stmt) call make_sp_call(coder,cblock,stmt,sym,3,0) contains include 'fisnull.inc' @@ -2294,7 +2287,7 @@ function code_par_scope_start(coder,cblock,stmt,var,using,& call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_num)) ! Alias the region variable - call make_var_tab_entry(coder,sym_region,coder%var(iter+lv_distr)) + call push_var(coder,sym_region,coder%var(iter+lv_distr)) ! Create the subregion variable call make_sys_var(coder,cblock,stmt,sym_subregion,var_is_shadowed) @@ -2875,8 +2868,6 @@ subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) var=find_var(coder,name) if(pm_fast_isnull(var)) then call make_definition(coder,cblock,node,lhs,0) - elseif(cnode_flags_set(var,var_flags,var_is_not_inited)) then - call var_init_in_cblock(coder,cblock,node,var,0) else call make_assignment(coder,cblock,node,lhs,rhs,var) endif @@ -3109,213 +3100,6 @@ recursive subroutine make_op_assignment_noalias(coder,cblock,pnode,node,op) endif end subroutine make_op_assignment_noalias - !=============================================================== - ! Traverse var or const definition with no immediate definition - !=============================================================== - subroutine trav_var_no_init(coder,cblock,pnode,node) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer:: n,flags,i - type(pm_ptr):: tnode - n=node_numargs(node)-1 - tnode=node_arg(node,n+1) - flags=var_is_not_inited - if(node_sym(node)==sym_var) flags=ior(flags,var_is_var) - do i=1,n - call make_var(coder,cblock,node,node_arg(node,i),flags,tnode) - call cache_var_init(coder,cblock,node,top_code(coder)) - if(pm_is_compiling) then - call make_sp_call(coder,cblock,node,sym_init_var,1,0) - else - call drop_code(coder) - endif - enddo - end subroutine trav_var_no_init - - !================================================================== - ! Initialise a variable in a nested block (relative to definition) - !================================================================== - subroutine var_init_in_cblock(coder,cblock,node,var,flags) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,var - integer,intent(in):: flags - type(pm_ptr):: p,def_block,tnode - logical:: has_if - - def_block=cnode_get(var,var_parent) - has_if=.false. - p=cblock - do while(.not.p==def_block) - select case(cnode_get_num(p,cblock_sym)) - case(sym_for) - call code_error(coder,node,& - 'Cannot intialise a "var" or "const" inside a nested "for" or "par"statement') - call cnode_error(coder,var,& - 'Variable definition incorrectly intialised by the above') - case(sym_if,sym_if_invar,sym_switch) - if(var_init_cached(coder,p,var)) then - if(.not.has_if) then - call code_error(coder,node,& - 'Cannot initialise variable twice: ',& - cnode_get(var,var_name)) - endif - exit - else - call cache_var_init(coder,p,node,var) - has_if=.true. - endif - case(sym_while,sym_until,sym_each) - call code_error(coder,node,& - 'Cannot initialise a variable defined outside '//& - 'of a sequential loop within that loop: ',& - cnode_get(var,var_name)) - call cnode_error(coder,var,& - 'Variable definition incorrectly intialised by the above') - case(sym_any) - call code_error(coder,node,& - 'Cannot initialise a variable defined outside '//& - 'of an "any" statement within that statement: ',& - cnode_get(var,var_name)) - call cnode_error(coder,var,& - 'Variable definition incorrectly intialised by the above') - end select - p=cnode_get(p,cblock_parent) - enddo - if(.not.has_if) then - call cnode_clear_flags(var,var_flags,var_is_not_inited) - endif - call trav_cast(coder,cblock,node,& - cnode_get(var,var_extra_info),& - merge(sym_var,sym_const,cnode_flags_set(var,var_flags,var_is_var))) - call init_var(coder,cblock,node,var) - contains - include 'fisnull.inc' - include 'fvkind.inc' - end subroutine var_init_in_cblock - - !======================================================== - ! Check 2 cblocks (or null) on the top of the - ! vstack to see if initialisations match - !======================================================== - subroutine resolve_if_inits(coder,node) - type(code_state):: coder - type(pm_ptr),intent(in):: node - type(pm_ptr):: cblock1,cblock2,cache1,cache2 - logical:: empty1,empty2 - integer:: i - cblock1=coder%vstack(coder%vtop-1) - cblock2=coder%vstack(coder%vtop) - cache1=cnode_get(cblock1,cblock_var_inits) - if(pm_fast_isnull(cblock2)) then - cache2=pm_null_obj - else - cache2=cnode_get(cblock2,cblock_var_inits) - endif - empty1=pm_fast_isnull(cache1) - empty2=pm_fast_isnull(cache2) - if(empty1.and.empty2) then - return - elseif(.not.(empty1.or.empty2)) then - if(pm_dict_size(coder%context,cache1)>& - pm_dict_size(coder%context,cache2)) then - call compare(cache1,cache2) - else - call compare(cache2,cache1) - endif - else - if(empty1) cache1=cache2 - do i=1,pm_dict_size(coder%context,cache1) - call error(cache1,i) - enddo - endif - contains - include 'fisnull.inc' - - ! Compare larger cache1 to cache2 - subroutine compare(cache1,cache2) - type(pm_ptr),intent(in):: cache1,cache2 - type(pm_ptr):: var,dblock,p - integer:: i - - outer: do i=1,pm_dict_size(coder%context,cache1) - if(pm_fast_isnull(pm_dict_lookup(coder%context,cache2,& - pm_dict_key(coder%context,cache1,int(i,pm_ln))))) then - call error(cache1,i) - endif - ! Check if variable is now completely initialised - ! (true if not still nested in any conditional statement) - var=pm_dict_val(coder%context,cache1,int(i,pm_ln)) - dblock=cnode_get(var,var_parent) - p=cnode_get(cblock1,cblock_parent) - do while(.not.p==dblock) - select case(cnode_get_num(p,cblock_sym)) - case(sym_if,sym_if_invar) - cycle outer - end select - p=cnode_get(p,cblock_parent) - enddo - call cnode_clear_flags(var,var_flags,var_is_not_inited) - enddo outer - end subroutine compare - - subroutine error(cache,j) - type(pm_ptr):: cache - integer:: j - call code_error(coder,node,& - 'Variable is only intialised in one branch of this if statement: ',& - cnode_get(pm_dict_val(coder%context,cache,int(j,pm_ln)),var_name)) - end subroutine error - - end subroutine resolve_if_inits - - !==================================================================== - ! Check if variable initialisation is in the cache for a given block - !==================================================================== - function var_init_cached(coder,cblock,var) result(iscached) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,var - logical:: iscached - type(pm_ptr):: index,cache - index=cnode_get(var,var_index) - cache=cnode_get(cblock,cblock_var_inits) - if(pm_fast_isnull(cache)) then - iscached=.false. - else - iscached=.not.pm_fast_isnull(pm_dict_lookup(coder%context,& - cache,index)) - endif - contains - include 'fisnull.inc' - end function var_init_cached - - !======================================================== - ! Add a variable initialisation to the cache for a block - !======================================================== - subroutine cache_var_init(coder,cblock,node,var) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,var - type(pm_ptr):: index,cache,tnode2 - logical:: ok - integer(pm_ln):: i - index=cnode_get(var,var_index) - cache=cnode_get(cblock,cblock_var_inits) - if(pm_fast_isnull(cache)) then - cache=pm_dict_new(coder%context,8_pm_ln) - call pm_ptr_assign(coder%context,cblock,& - int(cblock_var_inits,pm_ln),& - cache) - endif - call pm_dict_set(coder%context,cache,index,var,.true.,.false.,ok) - if(.not.ok) then - call code_error(coder,node,& - 'Cannot re-initialise variable: ',& - cnode_get(var,var_name)) - endif - contains - include 'fisnull.inc' - include 'ftiny.inc' - end subroutine cache_var_init - !=================================================================== ! Use expression on top of stack to create new variable or constant !=================================================================== @@ -3334,7 +3118,6 @@ recursive subroutine make_definition(coder,cblock,node,vname,flags) pnode=node endif if(pm_fast_isname(name)) then - var=find_var(coder,name) call make_var(coder,cblock,pnode,name,flags) var=top_code(coder) call swap_code(coder) @@ -4138,7 +3921,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) p%offset==sym_true) else call make_const(coder,cblock,node,p,& - pm_new_value_typ(coder%context,p)) + pm_new_value_type(coder%context,p)) endif return case(sym_fix) @@ -4360,7 +4143,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) if(coder%fixed) then p=node_arg(node,1) call make_const(coder,cblock,node,p,& - pm_new_value_typ(coder%context,p)) + pm_new_value_type(coder%context,p)) else call make_const(coder,cblock,node,node_arg(node,1)) endif @@ -4385,7 +4168,7 @@ subroutine name_const(pnode,nm) integer:: junk call make_const(coder,cblock,pnode,& pm_fast_name(coder%context,nm),& - pm_new_name_typ(coder%context,nm)) + pm_new_name_type(coder%context,nm)) end subroutine name_const subroutine range_const(p,n) @@ -4416,36 +4199,6 @@ end subroutine array_span end subroutine trav_expr - !======================================================== - ! Traverse single variable in an expression - !======================================================== - subroutine trav_var(coder,cblock,node,name) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,name - type(pm_ptr):: var - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call code_error(coder,node,'Variable has not been defined: ',name) - call make_temp_var(coder,cblock,node) - return - endif - if(cnode_flags_set(var,var_flags,var_is_not_inited)) then - call code_error(coder,node,& - 'Variable is not yet initialised: ',name) - endif - if(cnode_flags_set(var,var_flags,var_is_aliased)) then - coder%aliased=.true. - var=cnode_get(var,var_extra_info) - endif - if(cnode_flags_set(var,var_flags,var_is_sync)) then - call cnode_error(coder,node,& - 'Cannot access "sync" left-hand-side variable in right-hand-side expression') - endif - call code_val(coder,var) - contains - include 'fisnull.inc' - end subroutine trav_var - !================================================================== ! Name in usual expression context (may be variable or parameter) !================================================================== @@ -4573,10 +4326,10 @@ recursive subroutine trav_structrec(coder,cblock,node) if(pm_fast_isnull(node_arg(node,1))) then call code_num(coder,-1) tno=info%data%i(info%offset+1) - tno=pm_typ_arg(coder%context,tno,1) + tno=pm_type_arg(coder%context,tno,1) else call trav_type(coder,node,node_arg(node,1)) - tno=pm_user_typ_body(coder%context,top_word(coder)) + tno=pm_user_type_body(coder%context,top_word(coder)) call code_num(coder,pop_word(coder)) endif ! At this point tno contains the body of the struct/rec type @@ -4594,7 +4347,7 @@ recursive subroutine trav_structrec(coder,cblock,node) if(nam1==nam2) then count=count+1 call code_val(coder,coder%vstack(vbase+i)) - call cast_element(node_arg(exprs,i),pm_typ_arg(coder%context,tno,j)) + call cast_element(node_arg(exprs,i),pm_type_arg(coder%context,tno,j)) cycle outer endif enddo @@ -4766,7 +4519,7 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,0) case(sym_or) n=node_numargs(node) - call push_word(coder,pm_typ_new_any) + call push_word(coder,pm_type_new_any) call push_word(coder,0) do i=1,n call trav_type(coder,pnode,node_arg(node,i)) @@ -4774,24 +4527,24 @@ recursive subroutine trav_type(coder,pnode,node) call make_type(coder,2+n) case(sym_and) n=node_numargs(node) - call push_word(coder,pm_typ_new_all) + call push_word(coder,pm_type_new_all) call push_word(coder,0) do i=1,n call trav_type(coder,pnode,node_arg(node,i)) enddo call make_type(coder,2+n) case(sym_pval) - call push_word(coder,pm_typ_new_poly) + call push_word(coder,pm_type_new_poly) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_type_val) - call push_word(coder,pm_typ_new_type) + call push_word(coder,pm_type_new_type) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_includes) - call push_word(coder,pm_typ_new_includes) + call push_word(coder,pm_type_new_includes) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) typno=top_word(coder) @@ -4825,7 +4578,7 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,proc_type_from_decl(coder,p,node)) case(sym_unique) name=node_arg(node,1) - call push_word(coder,pm_new_name_typ(coder%context,int(name%offset))) + call push_word(coder,pm_new_name_type(coder%context,int(name%offset))) case(sym_dash) name=node_arg(node,1) if(pm_fast_isname(name)) then @@ -4835,20 +4588,20 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,coder%false_name) endif else - call push_word(coder,pm_new_value_typ(coder%context,name)) + call push_word(coder,pm_new_value_type(coder%context,name)) endif case(sym_contains) - call push_word(coder,pm_typ_new_contains) + call push_word(coder,pm_type_new_contains) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_casts_to) - call push_word(coder,pm_typ_new_has) + call push_word(coder,pm_type_new_has) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_except) - call push_word(coder,pm_typ_new_except) + call push_word(coder,pm_type_new_except) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call trav_type(coder,pnode,node_arg(node,2)) @@ -4857,7 +4610,7 @@ recursive subroutine trav_type(coder,pnode,node) call trav_type_decl(coder,pnode,node) case(sym_open_brace) name=node_arg(node,1) - call push_word(coder,pm_typ_new_user) + call push_word(coder,pm_type_new_user) call push_word(coder,int(name%offset)) typno=get_typeno(2) if(typno==0) call pm_panic('Intrinsic type not found') @@ -4866,9 +4619,9 @@ recursive subroutine trav_type(coder,pnode,node) flags=node_num_arg(node,7) name=node_arg(node,2) if(sym==sym_struct) then - call push_word(coder,pm_typ_new_struct+flags) + call push_word(coder,pm_type_new_struct+flags) else - call push_word(coder,pm_typ_new_rec+flags) + call push_word(coder,pm_type_new_rec+flags) endif call push_word(coder,abs(int(name%offset))) val=node_arg(node,1) @@ -4878,31 +4631,31 @@ recursive subroutine trav_type(coder,pnode,node) enddo call make_type(coder,n+2) case(sym_caret) - call push_word(coder,pm_typ_new_array) + call push_word(coder,pm_type_new_array) call push_word(coder,node_get_num(node,node_args+1)) call trav_type(coder,pnode,node_arg(node,1)) call trav_type(coder,pnode,node_arg(node,3)) call push_word(coder,int(pm_long)) call make_type(coder,5) case(sym_dcaret) - call push_word(coder,pm_typ_new_vect) + call push_word(coder,pm_type_new_vect) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_underscore) - call push_word(coder,pm_typ_new_bottom) + call push_word(coder,pm_type_new_bottom) call push_word(coder,0) call make_type(coder,2) case(sym_const) - call push_word(coder,pm_typ_new_const) + call push_word(coder,pm_type_new_const) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_list,sym_dotdotdot) if(sym==sym_dotdotdot) then - call push_word(coder,pm_typ_new_vtuple) + call push_word(coder,pm_type_new_vtuple) else - call push_word(coder,pm_typ_new_tuple) + call push_word(coder,pm_type_new_tuple) endif call push_word(coder,0) base=coder%wtop @@ -4918,7 +4671,7 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_define,sym_var) call trav_type(coder,pnode,node_arg(node,1)) case(sym_pm_dref) - call push_word(coder,pm_typ_is_dref) + call push_word(coder,pm_type_is_dref) n=node_get_num(node,node_args) call push_word(coder,n) n=node_numargs(node) @@ -4927,7 +4680,7 @@ recursive subroutine trav_type(coder,pnode,node) enddo call make_type(coder,n+1) case(sym_amp) - call push_word(coder,pm_typ_new_amp) + call push_word(coder,pm_type_new_amp) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) @@ -4935,10 +4688,10 @@ recursive subroutine trav_type(coder,pnode,node) call trav_type(coder,pnode,node_arg(node,1)) typno=pop_word(coder) call push_word(coder,& - pm_typ_add_mode(coder%context,typno,& + pm_type_add_mode(coder%context,typno,& node_num_arg(node,2),.false.,.true.)) case(sym_result) - call push_word(coder,pm_typ_new_tuple) + call push_word(coder,pm_type_new_tuple) call push_word(coder,0) n=node_numargs(node) do i=1,n @@ -4971,7 +4724,7 @@ recursive subroutine trav_type(coder,pnode,node) function get_typeno(size) result(tno) integer,intent(in):: size integer:: tno - tno=pm_typ_lookup(coder%context,& + tno=pm_type_lookup(coder%context,& coder%wstack(coder%wtop-size+1:coder%wtop)) end function get_typeno @@ -4979,7 +4732,7 @@ end function get_typeno function get_user_typeno(size) result(tno) integer,intent(in):: size integer:: tno - tno=pm_user_typ_lookup(coder%context,& + tno=pm_user_type_lookup(coder%context,& coder%wstack(coder%wtop-size+1:coder%wtop)) end function get_user_typeno @@ -4987,7 +4740,7 @@ recursive subroutine proc_type type(pm_ptr):: dp,list,arg integer:: i,j,n,base - call push_word(coder,pm_typ_new_proc) + call push_word(coder,pm_type_new_proc) call push_word(coder,0) base=coder%wtop @@ -4998,13 +4751,13 @@ recursive subroutine proc_type 'Cannot shadow type-match parameter:',node_arg(dp,i)) endif enddo - call push_word(coder,pm_typ_new_proc_sig) + call push_word(coder,pm_type_new_proc_sig) call push_word(coder,node_get_num(node,node_args+1)) do i=3,4 list=node_arg(node,i) call push_word(coder,& - merge(pm_typ_is_vtuple,pm_typ_is_tuple,node_sym(list)==sym_dotdotdot)) + merge(pm_type_is_vtuple,pm_type_is_tuple,node_sym(list)==sym_dotdotdot)) if(i==4.or.pm_fast_isnull(node_arg(node,5))) then call push_word(coder,0) else @@ -5037,7 +4790,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) type(pm_ptr):: namenode,name,decl,dec,inc,pargs,also_dec type(pm_ptr):: twice_dec,main_dec,tname,tval,pars,newdec type(pm_ptr),target:: incset - logical:: is_present,also_present,type_present,is_interface + logical:: is_present,also_present,type_present logical:: dotdotdot_present,multiple_modules,twice,has_constraints integer:: nargs,sym,i,j,n,base,parbase,ibase,npars,idepth integer:: new_type,tno @@ -5052,7 +4805,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) else name=node_arg(namenode,2) endif - call push_word(coder,pm_typ_new_user) + call push_word(coder,pm_type_new_user) call push_word(coder,-1) if(nargs>0) then ! Type arguments @@ -5123,7 +4876,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif ! Create user type entry - pointing to nothing to start with - new_type=pm_new_user_typ(coder%context,coder%wstack(base-nargs-1:base),0) + new_type=pm_new_user_type(coder%context,coder%wstack(base-nargs-1:base),0) ! Check for excessive recursion idepth=node_get_num(decl,node_args+4) @@ -5144,13 +4897,12 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Find main definition of type dotdotdot_present=.false. multiple_modules=.false. - is_interface=.false. dec=node_arg(decl,2) ibase=-1 do sym=node_sym(dec) select case(sym) - case(sym_includes,sym_is,sym_dotdotdot,sym_interface) + case(sym_includes,sym_is,sym_dotdotdot) main_dec=dec parbase=coder%wtop pars=node_get(dec,typ_params) @@ -5166,11 +4918,10 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif has_constraints=.not.pm_fast_isnull(node_get(main_dec,typ_constraints)) if(sym/=sym_is) then - is_interface=sym==sym_interface inc=node_get(dec,typ_includes) if(.not.pm_fast_isnull(inc)) then ibase=coder%wtop - call push_word(coder,pm_typ_new_any) + call push_word(coder,pm_type_new_any) call push_word(coder,0) do i=1,node_numargs(inc) call trav_type(coder,pnode,node_arg(inc,i)) @@ -5181,7 +4932,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) else ibase=coder%wtop dotdotdot_present=.true. - call push_word(coder,pm_typ_new_any) + call push_word(coder,pm_type_new_any) call push_word(coder,0) endif else @@ -5226,11 +4977,6 @@ recursive subroutine trav_type_decl(coder,pnode,node) pm_null_obj,0,0) call trav_type(coder,pnode,node_arg(dec,2)) call pop_type_vars(coder) - if(is_interface) then - call defer_type_check(coder,dec,main_dec,& - new_type,top_word(coder),sym_includes,& - cnode_is_interface_constraint) - endif if(has_constraints) then call check_constraints(top_word(coder),dec) endif @@ -5257,11 +5003,6 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(.not.pm_fast_isnull(inc)) then do i=1,node_numargs(inc) call trav_type(coder,pnode,node_arg(inc,i)) - if(is_interface) then - call defer_type_check(coder,node_arg(inc,i),main_dec,& - new_type,top_word(coder),sym_includes,& - cnode_is_interface_constraint) - endif if(has_constraints) then call check_constraints(top_word(coder),dec) endif @@ -5269,9 +5010,9 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif call pop_type_vars(coder) else - ! sym_dotdotdot, sym_includes or sym_interface + ! sym_dotdotdot, sym_includes if(pm_debug_checks) then - if(sym/=sym_dotdotdot.and.sym/=sym_includes.and.sym/=sym_interface) then + if(sym/=sym_dotdotdot.and.sym/=sym_includes) then if(sym>=0.and.sym<=num_sym) then write(*,*) 'SYM=',trim(sym_names(sym)) else @@ -5280,7 +5021,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) call pm_panic('Not a type in trav_type_decl') endif endif - if(sym==sym_dotdotdot.or.sym==sym_interface) then + if(sym==sym_dotdotdot) then dotdotdot_present=.true. endif if(is_present.or.type_present) then @@ -5302,18 +5043,13 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Create a union type from the parts brought together if(.not.is_present.and.coder%wtop>ibase) then - if(node_sym(main_dec)==sym_interface) then - ! This is an interface type -- create it - call make_type(coder,coder%wtop-ibase) - call trav_interface(coder,node_get(main_dec,typ_interface),& - pop_word(coder)) - elseif(coder%wtop-ibase>3) then + if(coder%wtop-ibase>3) then call make_type(coder,coder%wtop-ibase) endif endif ! Set the body of the user type to be the new type - call pm_user_typ_set_body(coder%context,new_type,top_word(coder)) + call pm_user_type_set_body(coder%context,new_type,top_word(coder)) ! Tidy up and place new type on wstack base=base-nargs-1 @@ -5357,7 +5093,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(debug_codegen) then write(*,*) 'definition traversed for ',& trim(pm_name_as_string(coder%context,int(name%offset))),'#',top_word(coder) - write(*,*) '#', trim(pm_typ_as_string(coder%context,top_word(coder))) + write(*,*) '#', trim(pm_type_as_string(coder%context,top_word(coder))) endif return @@ -5386,7 +5122,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) function get_typeno(size) result(tno) integer,intent(in):: size integer:: tno - tno=pm_typ_lookup(coder%context,& + tno=pm_type_lookup(coder%context,& coder%wstack(coder%wtop-size+1:coder%wtop)) end function get_typeno @@ -5401,35 +5137,12 @@ subroutine check_constraints(tno,node) do i=1,node_numargs(constraints) call trav_type(coder,main_dec,node_arg(constraints,i)) call defer_type_check(coder,node,node_arg(constraints,i),pop_word(coder),tno,& - 0,cnode_is_typ_constraint) + 0,cnode_is_type_constraint) enddo end subroutine check_constraints end subroutine trav_type_decl - !=============================================================== - ! Traverse interface declaration and make type - ! base_type must be union of types conforming to the interface - !============================================================== - recursive subroutine trav_interface(coder,node,base_type) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node - integer,intent(in):: base_type - type(pm_ptr):: p,val - integer:: n,i - p=node_arg(node,2) - call push_word(coder,pm_typ_new_interface) - call push_word(coder,int(p%offset)) - call push_word(coder,base_type) - p=node_arg(node,1) - n=node_numargs(p) - do i=1,n - val=node_arg(p,i) - call trav_type(coder,val,val) - enddo - call make_type(coder,n+3) - end subroutine trav_interface - !=============================================================== ! Create a template type from struct/rec declaration @@ -5452,7 +5165,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) n=node_numargs(params) do i=1,n,2 arg=node_arg(params,i+1) - call push_word(coder,pm_typ_new_param) + call push_word(coder,pm_type_new_param) call push_word(coder,(i+1)/2) call trav_type(coder,arg,arg) call make_type(coder,3) @@ -5462,7 +5175,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) call trav_type(coder,pnode,decl) tno=pop_word(coder) call pop_type_vars(coder) - tno=pm_new_params_typ(coder%context,n,tno) + tno=pm_new_params_type(coder%context,n,tno) vect=pm_fast_newnc(coder%context,pm_int,5) call code_val(coder,vect) ! protect from GC vect%data%i(vect%offset)=node_num_arg(decl,2) @@ -5475,7 +5188,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) else call trav_type(coder,pnode,decl) tno=pop_word(coder) - tno=pm_new_params_typ(coder%context,0,tno) + tno=pm_new_params_type(coder%context,0,tno) vect=pm_fast_newnc(coder%context,pm_int,5) call code_val(coder,vect) ! protect from GC vect%data%i(vect%offset)=node_num_arg(decl,2) @@ -5486,7 +5199,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) call pm_ptr_assign(coder%context,decl,node_args+5_pm_ln,vect) call drop_code(coder) endif - call pm_typ_record_by_name(coder%context,& + call pm_type_record_by_name(coder%context,& node_get_num(decl,node_args+2),tno) coder%wtop=base contains @@ -5540,7 +5253,6 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& endif coder%top=coder%top+1 coder%stack(coder%top)=typevar_start - coder%link(coder%top)=0 coder%var(coder%top)=pm_null_obj base=coder%top @@ -5574,7 +5286,7 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& partyp,int(pname%offset),cnode_is_par_constraint) ! Intersect argument and parameter - call push_word(coder,pm_typ_new_all) + call push_word(coder,pm_type_new_all) call push_word(coder,0) call push_word(coder,min(vtyp,partyp)) call push_word(coder,max(vtyp,partyp)) @@ -5600,15 +5312,14 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& 'Repitition of type parameter name:',& pname) else - call make_var_tab_entry(coder,int(pname%offset),& + call push_var(coder,int(pname%offset),& pm_fast_tinyint(coder%context,vtyp)) endif enddo coder%top=coder%top+1 coder%stack(coder%top)=typevar_end - coder%link(coder%top)=base - coder%var(coder%top)=pm_null_obj + coder%var(coder%top)%offset=base contains include 'ftiny.inc' include 'fisnull.inc' @@ -5620,7 +5331,7 @@ end subroutine make_type_vars subroutine pop_type_vars(coder) type(code_state),intent(inout):: coder integer:: base - base=coder%link(coder%top) + base=coder%var(coder%top)%offset if(pm_debug_checks) then if(coder%stack(coder%top)/=typevar_end) & call pm_panic('Pop type vars - no end record') @@ -5641,21 +5352,19 @@ subroutine copy_type_vars(coder) type(code_state),intent(inout):: coder integer:: top,base,i,nbase top=coder%proc_base - base=coder%link(top) + base=coder%var(top)%offset coder%top=coder%top+1 nbase=coder%top coder%stack(coder%top)=typevar_start - coder%link(coder%top)=0 coder%var(coder%top)=pm_null_obj do i=base+1,top-1 if(coder%stack(i)/=0) then - call make_var_tab_entry(coder,coder%stack(i),coder%var(i)) + call push_var(coder,coder%stack(i),coder%var(i)) endif enddo coder%top=coder%top+1 coder%stack(coder%top)=typevar_end - coder%link(coder%top)=nbase - coder%var(coder%top)=pm_null_obj + coder%var(coder%top)%offset=nbase end subroutine copy_type_vars !======================================== @@ -5673,7 +5382,7 @@ function find_type_var(coder,vname) result(vr) vr=pm_null_obj else n=vname%offset - k=find_var_entry(coder,n,int(coder%link(coder%top))) + k=find_var_entry(coder,n,int(coder%var(coder%top)%offset)) if(k/=0) then vr=coder%var(k) else @@ -5709,7 +5418,7 @@ subroutine complete_type_checks(coder) integer:: k integer:: tno,tno1,tno2 type(pm_ptr):: tset,name - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo p=coder%prog_cblock keys=pm_dict_keys(coder%context,coder%context%tcache) vals=pm_dict_vals(coder%context,coder%context%tcache) @@ -5717,12 +5426,12 @@ subroutine complete_type_checks(coder) ! Check no named type is problematically recursive do i=0,pm_dict_size(coder%context,coder%context%tcache)-1 tv=keys%data%ptr(keys%offset+i) - if(pm_tv_kind(tv)==pm_typ_is_user) then + if(pm_tv_kind(tv)==pm_type_is_user) then tno=i+1 - if(pm_typ_is_recur(coder%context,tno,tno)) then + if(pm_type_is_recur(coder%context,tno,tno)) then call code_error(coder,pm_null_obj,& 'Type directly includes itself: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) call pm_ptr_assign(coder%context,vals,i,pm_null_obj) endif endif @@ -5731,16 +5440,16 @@ subroutine complete_type_checks(coder) ! Check all named types include themselves (weeds out some errors) do i=0,pm_dict_size(coder%context,coder%context%tcache)-1 tv=keys%data%ptr(keys%offset+i) - if(pm_tv_kind(tv)==pm_typ_is_user) then + if(pm_tv_kind(tv)==pm_type_is_user) then tno=i+1 ! Check type includes its body to avoid automatic true return - if(.not.pm_typ_includes(coder%context,tno,& - pm_user_typ_body(coder%context,tno),pm_typ_incl_typ,& + if(.not.pm_type_includes(coder%context,tno,& + pm_user_type_body(coder%context,tno),pm_type_incl_type,& einfo)) then call code_error(coder,pm_null_obj,& 'Type is incorrectly defined: '//& - trim(pm_typ_as_string(coder%context,tno))) - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno))) + call pm_type_error(coder%context,einfo) endif endif enddo @@ -5754,56 +5463,47 @@ subroutine complete_type_checks(coder) case(cnode_is_arg_constraint) tno1=cnode_num_arg(p,2) tno2=cnode_num_arg(p,3) - if(.not.pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_typ,& + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type,& einfo)) then call cnode_error(coder,p,& 'Type argument "'//& trim(pm_name_as_string(coder%context,& int(name%offset)))//& '" does not meet constraint: '//& - trim(pm_typ_as_string(coder%context,tno1))//& + trim(pm_type_as_string(coder%context,tno1))//& ' inc '//& - trim(pm_typ_as_string(coder%context,tno2))) - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno2))) + call pm_type_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Constraint that gave rise to above error') endif case(cnode_is_par_constraint) tno1=cnode_get_num(p,cnode_args+1) tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_typ,& + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type,& einfo)) then call cnode_error(coder,p,& 'Parameter "'//& trim(pm_name_as_string(coder%context,& int(name%offset)))//& '" does not match base type; parameter contraint: '//& - trim(pm_typ_as_string(coder%context,tno1))//& + trim(pm_type_as_string(coder%context,tno1))//& ' ,argument: '//& - trim(pm_typ_as_string(coder%context,tno2))) - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno2))) + call pm_type_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Constraint that gave rise to the above error') endif - case(cnode_is_typ_constraint) + case(cnode_is_type_constraint) tno1=cnode_get_num(p,cnode_args+1) tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_equiv,& + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_equiv,& einfo)) then call cnode_error(coder,p,'Type does not meet constraint:') - call pm_typ_error(coder%context,einfo) + call pm_type_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Type constraint referenced in above error') endif - case(cnode_is_interface_constraint) - tno1=pm_user_typ_body(coder%context,cnode_get_num(p,cnode_args+1)) - tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_interface_typ_conforms(coder%context,tno1,tno2,einfo)) then - call cnode_error(coder,p,'Type does not conform to interface') - call pm_typ_error(coder%context,einfo) - call code_error(coder,cnode_arg(p,5),& - 'Definition of interface referenced in above error') - endif end select p=cnode_arg(p,1) enddo @@ -6748,7 +6448,7 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) !coder%over_base=coder%top - call make_var_tab_entry(coder,sym_for,& + call push_var(coder,sym_for,& coder%var(loop_pars+1)) @@ -6767,12 +6467,12 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) call drop_code(coder) ! Alias the region and subregion variables - call make_var_tab_entry(coder,sym_region,coder%var(iter+lv_distr)) - call make_var_tab_entry(coder,sym_subregion,coder%var(loop_pars+2)) + call push_var(coder,sym_region,coder%var(iter+lv_distr)) + call push_var(coder,sym_subregion,coder%var(loop_pars+2)) coder%over_base =coder%top call push_par_scope(coder,cblock2) - call make_var_tab_entry(coder,sym_here_in_tile,coder%var(loop_pars+3)) + call push_var(coder,sym_here_in_tile,coder%var(loop_pars+3)) call make_sys_var(coder,cblock2,node,sym_here,var_is_shadowed) call code_val(coder,coder%var(iter+lv_tile)) call code_val(coder,coder%var(iter+lv_index)) @@ -6985,7 +6685,7 @@ function proc_type_from_decl(coder,node,cnode) result(proctyp) type(pm_ptr):: p p=node_arg(node,1) name=p%offset - call push_word(coder,pm_typ_new_proc) + call push_word(coder,pm_type_new_proc) call push_word(coder,name) n=2 p=node_arg(node,2) @@ -7022,7 +6722,7 @@ function proc_type_from_single_decl(coder,node,cnode) result(partyp) else sym=sym_proc endif - call push_word(coder,pm_typ_new_proc_sig) + call push_word(coder,pm_type_new_proc_sig) call push_word(coder,sym) call push_word(coder,proc_param_type(coder,node)) call push_word(coder,proc_result_type(coder,node)) @@ -7056,7 +6756,7 @@ function proc_param_type(coder,node) result(tno) if(tno>0) return p=node_get(node,proc_params) - call push_word(coder,merge(pm_typ_is_vtuple,pm_typ_is_tuple,& + call push_word(coder,merge(pm_type_is_vtuple,pm_type_is_tuple,& node_sym(p)==sym_dotdotdot)) amp=node_get(node,proc_amplocs) if(pm_fast_isnull(amp)) then @@ -7095,10 +6795,10 @@ function proc_result_type(coder,node) result(tno) if(pm_fast_isnull(p)) then nret=node_get_num(node,proc_numret) if(nret==0) then - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) else - call push_word(coder,pm_typ_is_undef_result) + call push_word(coder,pm_type_is_undef_result) call push_word(coder,nret) endif call make_type(coder,2) @@ -7106,7 +6806,7 @@ function proc_result_type(coder,node) result(tno) if(node_sym(p)==sym_dash) then p=node_arg(p,1) endif - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) nret=node_numargs(p) do i=1,nret @@ -7545,7 +7245,7 @@ subroutine sort_sig(coder,sig,signo) integer:: typ1,typ2,typ3,inter,union type(pm_ptr):: code,pars logical:: ok - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo start=sig%offset+cnode_args+2 end=sig%offset+pm_fast_esize(sig) if(debug_codegen) write(*,*) 'SORT SIGNATURE>',start,end @@ -7559,26 +7259,26 @@ subroutine sort_sig(coder,sig,signo) if(debug_codegen) then write(*,*) 'COMPARE SIGS>',typ1,typ2 write(*,*) '--------------------------------------' - write(*,*) trim(pm_typ_as_string(coder%context,typ2)) - write(*,*) trim(pm_typ_as_string(coder%context,typ1)) + write(*,*) trim(pm_type_as_string(coder%context,typ2)) + write(*,*) trim(pm_type_as_string(coder%context,typ1)) write(*,*) '--------------------------------------' endif if(typ1==typ2) then call cnode_error(coder,code,& 'Procedure "'//trim(sig_name_str(coder,signo))//& '" defined with identical signatures:'//& - trim(pm_typ_as_string(coder%context,typ2))) + trim(pm_type_as_string(coder%context,typ2))) call cnode_error(coder,sig%data%ptr(j+1),& 'Conflicting definition') return - else if(pm_typ_includes(coder%context,typ2,typ1,pm_typ_incl_typ,& + else if(pm_type_includes(coder%context,typ2,typ1,pm_type_incl_type,& einfo)) then if(debug_more_codegen) write(*,*) 'INCL' call check_nesting(code,sig%data%ptr(j+1)) exit else if(debug_more_codegen) write(*,*) 'NOT INCL' - if(pm_typ_includes(coder%context,typ1,typ2,pm_typ_incl_typ,& + if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type,& einfo)) then call check_nesting(sig%data%ptr(j+1),code) endif @@ -7649,16 +7349,16 @@ subroutine check_nesting(first,second) endif ret1=cnode_get_num(second,pr_rtype) ret2=cnode_get_num(first,pr_rtype) - tv1=pm_typ_vect(coder%context,ret1) - tv2=pm_typ_vect(coder%context,ret2) - if(pm_tv_kind(tv1)/=pm_typ_is_undef_result.and.& - pm_tv_kind(tv2)/=pm_typ_is_undef_result) then + tv1=pm_type_vect(coder%context,ret1) + tv2=pm_type_vect(coder%context,ret2) + if(pm_tv_kind(tv1)/=pm_type_is_undef_result.and.& + pm_tv_kind(tv2)/=pm_type_is_undef_result) then isbad=.false. do ii=1,pm_tv_numargs(tv1) rtype1=pm_tv_arg(tv1,ii) rtype2=pm_tv_arg(tv2,ii) - if(.not.pm_typ_includes(coder%context,& - rtype1,rtype2,pm_typ_incl_typ,einfo)) then + if(.not.pm_type_includes(coder%context,& + rtype1,rtype2,pm_type_incl_type,einfo)) then if(.not.isbad) then call cnode_error(coder,first,& 'Procedure "'//trim(sig_name_str(coder,signo))//& @@ -7667,10 +7367,10 @@ subroutine check_nesting(first,second) call more_error(coder%context,'Return value #'//& trim(pm_int_as_string(ii))//& ' in original procedure has type: '//& - trim(pm_typ_as_string(coder%context,rtype1))) + trim(pm_type_as_string(coder%context,rtype1))) call more_error(coder%context,& 'but in this procedure has type: '//& - trim(pm_typ_as_string(coder%context,rtype2))) + trim(pm_type_as_string(coder%context,rtype2))) isbad=.true. @@ -7823,7 +7523,7 @@ subroutine make_type(coder,size,val) if(coder%wtop<1) call pm_panic('make type') endif coder%wstack(coder%wtop)=& - pm_new_typ(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& + pm_new_type(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& val) end subroutine make_type @@ -7840,7 +7540,7 @@ subroutine make_basic_type(coder,size,val) if(coder%wtop<1) call pm_panic('make type') endif coder%wstack(coder%wtop)=& - pm_new_basic_typ(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& + pm_new_basic_type(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& val) end subroutine make_basic_type @@ -7853,11 +7553,11 @@ function make_user_type(coder,n,tno) result(new_type) integer,intent(in):: tno integer:: new_type integer:: deftyp - deftyp=pm_typ_lookup(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop)) + deftyp=pm_type_lookup(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop)) if(deftyp>=0) then new_type=-1 else - new_type=pm_new_typ(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop),& + new_type=pm_new_type(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop),& val=pm_fast_typeno(coder%context,tno)) endif contains @@ -7981,19 +7681,11 @@ function find_var_entry(coder,n,base) result(index) type(pm_ptr):: node index=0 - i=coder%hash(var_hash(n)) - if(pm_debug_checks) then - if(i>coder%top) then - write(*,*) '#',i,coder%top,var_hash(n) - call pm_panic('bad hash') - endif - endif - do while(i>base) + do i=coder%top,base+1,-1 if(coder%stack(i)==n) then index=i return endif - i=coder%link(i) enddo end function find_var_entry @@ -8145,8 +7837,8 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) call make_code(coder,node,cnode_is_var,var_node_size) endif - ! Add variable to hash table - call make_var_tab_entry(coder,int(name%offset),top_code(coder)) + ! Add variable to stack + call push_var(coder,int(name%offset),top_code(coder)) ! Link variable to enclosing code block link=cnode_get(cblock,cblock_last_var) @@ -8173,7 +7865,7 @@ end subroutine make_var !==================================================== ! Make an entry for a variable in the hash table !===================================================== - subroutine make_var_tab_entry(coder,name,var) + subroutine push_var(coder,name,var) type(code_state),intent(inout):: coder integer:: name type(pm_ptr),intent(in):: var @@ -8187,10 +7879,7 @@ subroutine make_var_tab_entry(coder,name,var) j=coder%top coder%stack(j)=name coder%var(j)=var - i=var_hash(coder%stack(j)) - coder%link(j)=coder%hash(i) - coder%hash(i)=j - end subroutine make_var_tab_entry + end subroutine push_var !===================================== ! Pop variables down to newbase @@ -8200,39 +7889,9 @@ subroutine pop_vars_to(coder,newbase) integer,intent(in):: newbase integer:: i,k integer:: j - if(pm_debug_checks) then - if(newbase>coder%top) call pm_panic('pop_vars_to') - endif - do i=coder%top,newbase+1,-1 - j=coder%stack(i) - if(j/=0) then - if(pm_debug_checks) then - if(j==typevar_start.or.j==typevar_end) then - write(*,*) 'i=',i,j - do j=coder%top,newbase+1,-1 - write(*,*) j,coder%stack(j),& - trim(pm_name_as_string(coder%context,max(0,coder%stack(j)))) - enddo - call pm_panic('Cannot pop typevar start/end') - endif - endif - k=var_hash(abs(j)) - coder%hash(k)=coder%link(i) - endif - enddo coder%top=newbase end subroutine pop_vars_to - !======================================= - ! Variable hash from variable name - !======================================= - function var_hash(n) result(h) - integer,intent(in):: n - integer:: h - h=iand(abs(int(n)),code_local_hash-1)+1 - h=1 - end function var_hash - !========================================= ! Make integer constant node (PM sint) !========================================= @@ -8278,7 +7937,7 @@ subroutine make_static_long_const(coder,cblock,node,val) ptr=pm_fast_newnc(coder%context,pm_long,1) ptr%data%ln(ptr%offset)=val coder%temp=ptr - call make_const(coder,cblock,node,ptr,pm_new_value_typ(coder%context,ptr)) + call make_const(coder,cblock,node,ptr,pm_new_value_type(coder%context,ptr)) coder%temp=pm_null_obj contains include 'fnewnc.inc' @@ -8312,7 +7971,7 @@ subroutine make_const(coder,cblock,node,val,typ) if(tno==pm_string) tno=pm_string_type if(present(typ)) tno=typ if(coder%par_state/=par_state_outer) then - tno=pm_typ_add_mode(coder%context,tno,sym_mirrored,.false.) + tno=pm_type_add_mode(coder%context,tno,sym_mirrored,.false.) endif call code_val(coder,val) call code_num(coder,tno) @@ -9193,13 +8852,13 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) write(iunit,*) spaces(1:depth*2),' Unresolved!!' else write(iunit,*) spaces(1:depth*2),' Resolved:',i,& - trim(pm_typ_as_string(coder%context,i)) + trim(pm_type_as_string(coder%context,i)) endif endif case(cnode_is_const) call pm_dump_tree(coder%context,iunit,cnode_arg(node,1),depth) !!$ write(iunit,*) spaces(1:depth*2),& -!!$ trim(pm_typ_as_string(coder%context,& +!!$ trim(pm_type_as_string(coder%context,& !!$ cnode_get_num(node,node_args+1))) case(cnode_is_call) p=cnode_get(node,call_sig) @@ -9316,7 +8975,7 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) else write(iunit,*) spaces(1:depth*2),'Sig List(',cnode_numargs(node) do i=2,cnode_numargs(node),2 - write(iunit,*) spaces(1:depth*2),trim(pm_typ_as_string(coder%context,& + write(iunit,*) spaces(1:depth*2),trim(pm_type_as_string(coder%context,& cnode_get_num(node,cnode_args+i-1))) call qdump_code_tree(coder,rvec,iunit,cnode_arg(node,i+1),depth+1) enddo @@ -9389,8 +9048,8 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) write(iunit,'(a)') ' [has vkeys]' if(cnode_flags_set(cnode,cnode_args+2,proc_is_dcomm)) & write(iunit,'(a)') ' [dcomm]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_variant)) & - write(iunit,'(a)') ' [variant]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_file)) & + write(iunit,'(a)') ' [file]' if(cnode_flags_set(cnode,cnode_args+2,proc_needs_par)) & write(iunit,'(a)') ' [needs par]' call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& @@ -9409,7 +9068,7 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) write(iunit,'(a)') ' '//& trim(pm_name_as_string(context,& key%data%i(key%offset+pm_fast_esize(key))))//& - trim(pm_typ_as_string(context,& + trim(pm_type_as_string(context,& cnode_num_arg(cnode,i)))//' {' call print_proc_cnode(context,iunit,pm_null_obj,& sig_cache,cnode_arg(cnode,i+1)) @@ -9597,7 +9256,7 @@ subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) "'"//trim(pm_name_as_string(context,int(cnode%offset))),.false.,depth) elseif(kind==pm_type) then call append_to_line(iunit,str,i,& - '<'//trim(pm_typ_as_string(context,int(cnode%offset)))//'>',.false.,depth) + '<'//trim(pm_type_as_string(context,int(cnode%offset)))//'>',.false.,depth) else kind=cnode_get_kind(cnode) select case(kind) @@ -9613,7 +9272,7 @@ subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) if(.not.pm_fast_isnull(rvec)) then tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) call append_to_line(iunit,str,i,& - '['//trim(pm_typ_as_string(context,tno))//']',.false.,depth) + '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) endif case(cnode_is_const) call append_to_line(iunit,str,i,& @@ -9805,7 +9464,7 @@ subroutine dump_sigs(coder,iunit) else do j=3,cnode_numargs(code),2 typ=cnode_arg(code,j) - write(iunit,*) 'Type:',trim(pm_typ_as_string(coder%context,& + write(iunit,*) 'Type:',trim(pm_type_as_string(coder%context,& int(typ%offset))) write(iunit,*) 'Code:',j,cnode_numargs(code) call qdump_code_tree(coder,pm_null_obj,iunit,cnode_arg(code,j+1),2) diff --git a/src/infer.f90 b/src/infer.f90 index e52b2a7..132f7ba 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -227,7 +227,7 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& write(*,*) 'PRC PROC>',key(1),key(2),key(3),key(4),k,& trim(pm_name_as_string(coder%context,& cnode_get_name(prc,pr_name))),& - trim(pm_typ_as_string(coder%context,atype)) + trim(pm_type_as_string(coder%context,atype)) endif ! This combination already cached @@ -301,9 +301,9 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& call infer_error(coder,prc,'Keyword/argument type mismatch:',& pm_set_key(coder%context,keynames,int(i+1,pm_ln))) call more_error(coder%context,'Mismatched argument: '//& - trim(pm_typ_as_string(coder%context,keyargtyp))) + trim(pm_type_as_string(coder%context,keyargtyp))) call more_error(coder%context,'Mismatched parameter: '//& - trim(pm_typ_as_string(coder%context,keypartyp))) + trim(pm_type_as_string(coder%context,keypartyp))) call infer_trace(coder) endif endif @@ -568,13 +568,13 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) integer:: sym type(pm_ptr):: tv,tv2 logical:: isstatic - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo p=cnode_get(prc,bi_rcode) if(pm_fast_istiny(p)) then - tv=pm_typ_vect(coder%context,atype) - tv=pm_typ_vect(coder%context,pm_tv_arg(tv,1)) + tv=pm_type_vect(coder%context,atype) + tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) rtype=(pm_tv_arg(tv,int(p%offset))) elseif(pm_fast_isnull(p)) then rtype=cnode_get_num(prc,bi_rtype) @@ -584,16 +584,16 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) else ! Convert type to concrete only representation and cache it if(rtype/=0) then - rtype=pm_typ_as_concrete(coder%context,rtype,coder%wstack,& + rtype=pm_type_as_concrete(coder%context,rtype,coder%wstack,& isstatic) if(isstatic) call cnode_set_num(prc,bi_rtype,int(-rtype)) endif endif if(cnode_get_num(prc,bi_rsym)==sym_dash) then - tv=pm_typ_vect(coder%context,atype) + tv=pm_type_vect(coder%context,atype) do i=1,pm_tv_numargs(tv) - tv2=pm_typ_vect(coder%context,pm_tv_arg(tv,i)) - if(pm_tv_kind(tv2)/=pm_typ_is_value) goto 20 + tv2=pm_type_vect(coder%context,pm_tv_arg(tv,i)) + if(pm_tv_kind(tv2)/=pm_type_is_value) goto 20 enddo call fold if(pm_is_compiling) then @@ -615,79 +615,79 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) ! Specified by special character in return spec select case(sym) case(sym_hash,sym_pct) - tv=pm_typ_vect(coder%context,rtype) - tv=pm_typ_vect(coder%context,pm_tv_arg(tv,1)) + tv=pm_type_vect(coder%context,rtype) + tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) if(sym==sym_hash) then rtype=(pm_tv_arg(tv,2)) else rtype=(pm_tv_arg(tv,1)) endif case(sym_dim1:sym_dim7) - tv=pm_typ_vect(coder%context,rtype) - tv=pm_typ_vect(coder%context,pm_typ_strip_mode(coder%context,& + tv=pm_type_vect(coder%context,rtype) + tv=pm_type_vect(coder%context,pm_type_strip_mode(coder%context,& pm_tv_arg(tv,1),mode)) - if(pm_tv_kind(tv)==pm_typ_is_vect) then - tv=pm_typ_vect(coder%context,pm_tv_arg(tv,1)) + if(pm_tv_kind(tv)==pm_type_is_vect) then + tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) endif rtype=pm_tv_arg(tv,int(sym-sym_dim1+1)) case(sym_d1:sym_d7) - tv=pm_typ_vect(coder%context,rtype) - tv=pm_typ_vect(coder%context,pm_typ_strip_mode(coder%context,& + tv=pm_type_vect(coder%context,rtype) + tv=pm_type_vect(coder%context,pm_type_strip_mode(coder%context,& pm_tv_arg(tv,1),mode)) - if(pm_tv_kind(tv)==pm_typ_is_vect) then + if(pm_tv_kind(tv)==pm_type_is_vect) then rtype=pm_tv_arg(tv,1) - tv=pm_typ_vect(coder%context,rtype) - rtype=pm_typ_strip_mode(coder%context,pm_tv_arg(tv,int(sym-sym_d1+1)),mode) + tv=pm_type_vect(coder%context,rtype) + rtype=pm_type_strip_mode(coder%context,pm_tv_arg(tv,int(sym-sym_d1+1)),mode) if(mode0.and.(coder%par_kind==par_mode_conc)) then - if(iand(pm_typ_flags(coder%context,tno),& - pm_typ_has_distributed)/=0) then - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(3),mode) - if(iand(pm_typ_flags(coder%context,tno),& - pm_typ_has_distributed)==0) then + if(iand(pm_type_flags(coder%context,tno),& + pm_type_has_distributed)/=0) then + tno=pm_type_strip_mode(coder%context,arg_type_with_mode(3),mode) + if(iand(pm_type_flags(coder%context,tno),& + pm_type_has_distributed)==0) then if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then call infer_error_with_trace(coder,callnode,& 'Cannot import distributed value into mirrored "forall"') @@ -914,19 +914,19 @@ subroutine prc_call(coder,cblock,callnode,base) case(sym_import_varg) tno=arg_type(2) if(tno>0) then - t=pm_typ_vect(coder%context,arg_type(2)) + t=pm_type_vect(coder%context,arg_type(2)) n=pm_tv_numargs(t) - call push_word(coder,pm_typ_new_tuple) + call push_word(coder,pm_type_new_tuple) call push_word(coder,0) do i=1,n - tno=pm_typ_strip_mode(coder%context,pm_tv_arg(t,i),mode) - if(iand(pm_typ_flags(coder%context,tno),pm_typ_has_distributed)/=0) then + tno=pm_type_strip_mode(coder%context,pm_tv_arg(t,i),mode) + if(iand(pm_type_flags(coder%context,tno),pm_type_has_distributed)/=0) then call infer_error_with_trace(coder,callnode,& 'Cannot use a distibuted shared value as an argument'//& ' to a non-communicating operation') endif call push_word(coder,& - pm_typ_add_mode(coder%context,tno,sym_shared,.false.)) + pm_type_add_mode(coder%context,tno,sym_shared,.false.)) enddo call make_type(coder,n+2) tno=pop_word(coder) @@ -934,12 +934,12 @@ subroutine prc_call(coder,cblock,callnode,base) call flag_import_export(tno) endif case(sym_import_shared) - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(2),mode) - coder%stack(get_slot(1))=pm_typ_add_mode(coder%context,tno,sym_shared,.false.) + tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) + coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,sym_shared,.false.) call flag_import_export(tno) case(sym_export) tno=arg_type_with_mode(1) - mode=pm_typ_get_mode(coder%context,tno) + mode=pm_type_get_mode(coder%context,tno) if(mode/=sym_coherent.and.mode/=sym_partial) then call infer_error(coder,callnode,& 'Cannot modify "'//trim(sym_names(mode))//'" variable as a "shared" value '//& @@ -963,16 +963,16 @@ subroutine prc_call(coder,cblock,callnode,base) call check_long(5) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long - tno=pm_typ_strip_mode_and_vect(coder%context,arg_type(4)) - t=pm_typ_vect(coder%context,tno) - if(pm_tv_kind(t)/=pm_typ_is_dref) then + tno=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) + t=pm_type_vect(coder%context,tno) + if(pm_tv_kind(t)/=pm_type_is_dref) then call infer_error(coder,callnode,'Internal compiler error: Not a d-ref.') endif - coder%stack(get_slot(2))=pm_typ_strip_mode_and_vect(coder%context,arg_type(4)) + coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) if(sig==sym_pm_send.or.sig==sym_pm_collect) then - coder%stack(get_slot(3))=pm_typ_strip_mode_and_vect(coder%context,arg_type(6)) + coder%stack(get_slot(3))=pm_type_strip_mode_and_vect(coder%context,arg_type(6)) else - coder%stack(get_slot(3))=pm_typ_strip_mode(coder%context,pm_tv_arg(t,1),mode) + coder%stack(get_slot(3))=pm_type_strip_mode(coder%context,pm_tv_arg(t,1),mode) endif call prc_cblock(coder,cnode_arg(args,8),base) case(sym_pm_bcast) @@ -984,27 +984,27 @@ subroutine prc_call(coder,cblock,callnode,base) case(sym_pm_recv_req) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long - coder%stack(get_slot(2))=pm_typ_strip_mode_and_vect(coder%context,arg_type(3)) + coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(3)) call prc_cblock(coder,cnode_arg(args,5),base) case(sym_pm_recv_assn) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long - coder%stack(get_slot(2))=pm_typ_strip_mode_and_vect(coder%context,arg_type(4)) - coder%stack(get_slot(3))=pm_typ_strip_mode_and_vect(coder%context,arg_type(5)) + coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) + coder%stack(get_slot(3))=pm_type_strip_mode_and_vect(coder%context,arg_type(5)) call prc_cblock(coder,cnode_arg(args,7),base) case(sym_pm_do,sym_pm_do_at) do i=merge(1,3,sig==sym_pm_do),nargs-1,2 - coder%stack(get_slot(i))=pm_typ_strip_mode_and_vect(coder%context,arg_type(i+1)) + coder%stack(get_slot(i))=pm_type_strip_mode_and_vect(coder%context,arg_type(i+1)) enddo call prc_cblock(coder,cnode_arg(args,nargs),base) case(sym_pm_head_node) call prc_cblock(coder,cnode_arg(args,1),base) case(sym_pm_dref:sym_pm_ref) - call push_word(coder,pm_typ_new_dref) + call push_word(coder,pm_type_new_dref) slot=coder%wtop call push_word(coder,sym_pm_dref-sig-1) if(nargs==3) then - t=pm_typ_vect(coder%context,arg_type(3)) + t=pm_type_vect(coder%context,arg_type(3)) call push_word(coder,arg_type_with_mode(2)) call push_word(coder,arg_type_with_mode(3)) call push_word(coder,arg_type_with_mode(4)) @@ -1021,13 +1021,13 @@ subroutine prc_call(coder,cblock,callnode,base) if(debug_inference) then do i=4,0,-1 write(*,*) 'DREF[',i,']',& - trim(pm_typ_as_string(coder%context,coder%wstack(coder%wtop-i))) + trim(pm_type_as_string(coder%context,coder%wstack(coder%wtop-i))) enddo endif call make_type_if_possible(coder,nargs+2) endif if(debug_inference) write(*,*) 'DREF=',& - trim(pm_typ_as_string(coder%context,top_word(coder))) + trim(pm_type_as_string(coder%context,top_word(coder))) coder%stack(get_slot(1))=pop_word(coder) case(sym_hash) if(arg_type(2)/=pm_null) then @@ -1116,24 +1116,24 @@ subroutine prc_call(coder,cblock,callnode,base) t=cnode_arg(args,2) t=cnode_arg(t,1) if(cnode_num_arg(args,3)>=0) then - tno=pm_user_typ_body(coder%context,cnode_num_arg(args,3)) - t2=pm_typ_vect(coder%context,tno) + tno=pm_user_type_body(coder%context,cnode_num_arg(args,3)) + t2=pm_type_vect(coder%context,tno) else tno=t%data%i(t%offset+1) - t2=pm_typ_vect(coder%context,pm_tv_arg(pm_typ_vect(coder%context,tno),1)) + t2=pm_type_vect(coder%context,pm_tv_arg(pm_type_vect(coder%context,tno),1)) endif name=t%data%i(t%offset+2) if(sig==sym_struct) then - call push_word(coder,pm_typ_new_struct+t%data%i(t%offset+4)) + call push_word(coder,pm_type_new_struct+t%data%i(t%offset+4)) else - call push_word(coder,pm_typ_new_rec+t%data%i(t%offset+4)) + call push_word(coder,pm_type_new_rec+t%data%i(t%offset+4)) endif call push_word(coder,t%data%i(t%offset)) do i=1,nargs-2 call push_word(coder,arg_type_with_mode(i+3)) enddo - mode=pm_typ_combine_modes(coder%context,& + mode=pm_type_combine_modes(coder%context,& coder%wstack(coder%wtop-nargs+3:coder%wtop),.false.,& cnode_flags_set(callnode,call_flags,proc_run_complete),& cnode_flags_set(callnode,call_flags,call_is_cond),& @@ -1156,37 +1156,37 @@ subroutine prc_call(coder,cblock,callnode,base) mode=sym_mirrored endif do i=1,nargs-2 - tno2=pm_typ_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+2+i),mode2) + tno2=pm_type_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+2+i),mode2) tno3=pm_tv_arg(t2,i) if(tno2==pm_tiny_int) then tno2=tno3 - if(tno2==0.or.iand(pm_typ_flags(coder%context,tno2),& - pm_typ_has_storage)/=0) then + if(tno2==0.or.iand(pm_type_flags(coder%context,tno2),& + pm_type_has_storage)/=0) then namep=pm_name_val(coder%context,pm_tv_name(t2)) call infer_error(coder,callnode,'Element "'//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset+i)))//& - ':'//trim(pm_typ_as_string(coder%context,tno2))//'" of "'//& + ':'//trim(pm_type_as_string(coder%context,tno2))//'" of "'//& trim(pm_name_as_string(coder%context,name))//& '" needs to be initialised') endif endif -!!$ tno4=pm_typ_convert(coder%context,tno3,tno2,sig==sym_struct) +!!$ tno4=pm_type_convert(coder%context,tno3,tno2,sig==sym_struct) !!$ if(tno4>0) then -!!$ if(iand(pm_typ_flags(coder%context,tno4),pm_typ_has_params)/=0) then +!!$ if(iand(pm_type_flags(coder%context,tno4),pm_type_has_params)/=0) then !!$ namep=pm_name_val(coder%context,pm_tv_name(t2)) !!$ call infer_error(coder,callnode,'Element "'//& !!$ trim(pm_name_as_string(coder%context,& !!$ namep%data%i(namep%offset+i)))//& -!!$ ':'//trim(pm_typ_as_string(coder%context,tno4))//'" of "'//& +!!$ ':'//trim(pm_type_as_string(coder%context,tno4))//'" of "'//& !!$ trim(pm_name_as_string(coder%context,name))//& !!$ '" cannot be initialised') !!$ call more_error(coder%context,& !!$ 'unless the "new" statement supplies explict parameters for the type: new T(...) { }"') !!$ endif !!$ tno2=tno4 -!!$ !write(*,*) 'Converted to:',trim(pm_typ_as_string(coder%context,tno4)) +!!$ !write(*,*) 'Converted to:',trim(pm_type_as_string(coder%context,tno4)) !!$ endif coder%wstack(coder%wtop-nargs+2+i)=tno2 @@ -1194,25 +1194,25 @@ subroutine prc_call(coder,cblock,callnode,base) call make_type_if_possible(coder,nargs) tno2=pop_word(coder) if(tno2>0) then - if(.not.pm_typ_includes(coder%context,tno,tno2,& - pm_typ_incl_val,einfo)) then + if(.not.pm_type_includes(coder%context,tno,tno2,& + pm_type_incl_val,einfo)) then call infer_error(coder,callnode,& '"'//trim(sym_names(sig))//& '" initial expression has wrong type for: ',& pm_fast_name(coder%context,name)) - call pm_typ_error(coder%context,einfo) + call pm_type_error(coder%context,einfo) call infer_trace(coder) tno2=error_type endif endif - tno2=pm_typ_add_mode(coder%context,tno2,mode,& + tno2=pm_type_add_mode(coder%context,tno2,mode,& cnode_flags_set(callnode,call_flags,call_is_cond)) call combine_types(cnode_arg(args,1),tno2) case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref) if(sig==sym_get_dot.or.sig==sym_get_dot_ref) then tno=arg_type(3) if(tno/=error_type) then - namep=pm_typ_vect(coder%context,arg_type(3)) + namep=pm_type_vect(coder%context,arg_type(3)) name=pm_tv_name(namep) namep=pm_fast_name(coder%context,name) else @@ -1223,13 +1223,13 @@ subroutine prc_call(coder,cblock,callnode,base) namep=cnode_arg(cnode_arg(args,3),1) name=namep%offset endif - tno=pm_typ_strip_mode_and_cond(coder%context,& + tno=pm_type_strip_mode_and_cond(coder%context,& arg_type_with_mode(2),mode,cond) if(tno>0) then call set_call_sig(resolve_elem(tno,name,& sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) call combine_types(cnode_arg(args,1),& - pm_typ_add_mode(coder%context,tno2,mode,cond)) + pm_type_add_mode(coder%context,tno2,mode,cond)) else call set_arg_to_error_type(1) endif @@ -1253,24 +1253,24 @@ subroutine prc_call(coder,cblock,callnode,base) call set_arg_to_error_type(1) return endif - if(pm_typ_kind(coder%context,tno)==pm_typ_is_type) then - tno=pm_typ_arg(coder%context,tno,1) + if(pm_type_kind(coder%context,tno)==pm_type_is_type) then + tno=pm_type_arg(coder%context,tno,1) else call infer_error_with_trace(coder,callnode,& '"as" second argument is not a type') call set_arg_to_error_type(1) return endif - tno2=pm_typ_strip_mode_and_cond(coder%context,& + tno2=pm_type_strip_mode_and_cond(coder%context,& arg_type_with_mode(2),mode,cond) k=prc_cast(coder,callnode,tno,tno2,.true.) call set_call_sig(int(k)) call combine_types(cnode_arg(args,1),& - pm_typ_add_mode(coder%context,tno2,mode,cond)) + pm_type_add_mode(coder%context,tno2,mode,cond)) case(sym_var_set_mode) mode2=cnode_num_arg(args,2) - coder%stack(get_slot(1))=pm_typ_add_mode(coder%context,& - pm_typ_strip_mode(coder%context,& + coder%stack(get_slot(1))=pm_type_add_mode(coder%context,& + pm_type_strip_mode(coder%context,& arg_type_with_mode(1),mode),mode2,.false.) if(mode==sym_partial.or.& mode2>=sym_mirrored.and.mode=sym_mirrored) then call infer_error(coder,callnode,& 'Assignments to "'//trim(sym_names(tno))//& @@ -1310,13 +1310,13 @@ subroutine prc_call(coder,cblock,callnode,base) case(sym_type_val) tno=cnode_num_arg(cnode_arg(args,2),1) call combine_types(cnode_arg(args,1),& - pm_new_type_typ(coder%context,tno)) + pm_new_type_type(coder%context,tno)) case(sym_any) list2=cnode_arg(args,4) list2=cnode_arg(list2,1) slot=list2%data%i(list2%offset) slot2=list2%data%i(list2%offset+1) - tno=pm_typ_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) + tno=pm_type_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) t=check_poly(coder,tno) if(tno/=error_type.and..not.pm_fast_isnull(t)) then n=pm_set_size(coder%context,t) @@ -1325,7 +1325,7 @@ subroutine prc_call(coder,cblock,callnode,base) tno=list%data%i(list%offset) coder%stack(base+slot:base+slot2)=undefined coder%stack(get_slot(1))=& - pm_typ_add_mode(coder%context,tno,mode,cond) + pm_type_add_mode(coder%context,tno,mode,cond) call prc_cblock(coder,cnode_arg(args,2),base) call code_int_vec(coder,coder%stack,base+slot,base+slot2) enddo @@ -1354,15 +1354,15 @@ subroutine prc_call(coder,cblock,callnode,base) enddo return endif - t=pm_typ_vect(coder%context,tno) + t=pm_type_vect(coder%context,tno) tno2=pm_tv_kind(t) - flags=iand(pm_tv_flags(t),pm_typ_has_embedded) + flags=iand(pm_tv_flags(t),pm_type_has_embedded) name=pm_tv_name(t) n=nargs-4 - if(tno2==pm_typ_is_struct.or.tno2==pm_typ_is_rec) then + if(tno2==pm_type_is_struct.or.tno2==pm_type_is_rec) then do i=nret+7,nargs-1,2 tno=arg_type(i) - t2=pm_typ_vect(coder%context,tno) + t2=pm_type_vect(coder%context,tno) if(pm_tv_kind(t2)/=tno2) then if(coder%num_errors==0) & call infer_error_with_trace(coder,callnode,& @@ -1387,7 +1387,7 @@ subroutine prc_call(coder,cblock,callnode,base) do i=1,n do j=nret+5,nargs-1,2 tno=arg_type(j) - t2=pm_typ_vect(coder%context,tno) + t2=pm_type_vect(coder%context,tno) tno=pm_tv_arg(t2,i) coder%stack(get_slot(j+1))=tno enddo @@ -1404,15 +1404,15 @@ subroutine prc_call(coder,cblock,callnode,base) key,1,list) slot=cnode_get_num(callnode,call_index) coder%stack(base+slot)=k - tno3=pm_typ_from_recorded_name(coder%context,name) + tno3=pm_type_from_recorded_name(coder%context,name) do i=nret,1,-1 call make_type_if_possible(coder,n+2) - if(.not.pm_typ_includes(coder%context,tno3,tno2,pm_typ_incl_val,einfo)) then + if(.not.pm_type_includes(coder%context,tno3,tno2,pm_type_incl_val,einfo)) then call infer_error(coder,args,& '"'//trim(sym_names(tno2))//& '" initial expression has wrong type for: ',& pm_fast_name(coder%context,name)) - call pm_typ_error(coder%context,einfo) + call pm_type_error(coder%context,einfo) call infer_trace(coder) endif coder%stack(get_slot(i))=pop_word(coder) @@ -1434,7 +1434,7 @@ subroutine prc_call(coder,cblock,callnode,base) if(arg_type(1)/=pm_string_type.and.arg_type(1)/=error_type) then call infer_error_with_trace(coder,cnode_arg(args,1),& 'Check message is not a string, got:'//& - trim(pm_typ_as_string(coder%context,arg_type(1)))) + trim(pm_type_as_string(coder%context,arg_type(1)))) elseif(tno==coder%false_name) then if(cnode_get_kind(cnode_arg(args,1))==cnode_is_const) then call pm_strval(cnode_arg(cnode_arg(args,1),1),str) @@ -1449,17 +1449,17 @@ subroutine prc_call(coder,cblock,callnode,base) endif case(sym_dash) tno=arg_type(2) - t=pm_typ_vect(coder%context,tno) - if(iand(pm_tv_flags(t),pm_typ_has_storage)/=0) then + t=pm_type_vect(coder%context,tno) + if(iand(pm_tv_flags(t),pm_type_has_storage)/=0) then call infer_error_with_trace(coder,callnode,& 'Value after '' cannot be determined at compile time') endif coder%stack(get_slot(1))=tno case(sym_dcaret) - coder%stack(get_slot(1))=pm_new_vect_typ(coder%context,arg_type(2)) + coder%stack(get_slot(1))=pm_new_vect_type(coder%context,arg_type(2)) case(sym_open) if(nargs>0) then - t=pm_typ_vect(coder%context,coder%stack(base)) + t=pm_type_vect(coder%context,coder%stack(base)) n=pm_tv_numargs(t) do i=1,nargs slot=get_slot(i) @@ -1469,7 +1469,7 @@ subroutine prc_call(coder,cblock,callnode,base) pm_tv_arg(t,i+n-nargs),pm_tv_numargs(t) enddo if(n>nargs) then - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) j=0 do i=nargs,n @@ -1498,15 +1498,15 @@ subroutine prc_call(coder,cblock,callnode,base) elseif(nargs>3) then t=cnode_arg(args,6) t=cnode_arg(t,1) - if(.not.pm_typ_includes(coder%context,t%data%i(t%offset),& - slot2,pm_typ_incl_val,& + if(.not.pm_type_includes(coder%context,t%data%i(t%offset),& + slot2,pm_type_incl_val,& einfo)) then call infer_error(coder,callnode,'Keyword argument type mismatch:',& cnode_get(cnode_arg(args,1),var_name)) call more_error(coder%context,'Mismatched argument: '//& - trim(pm_typ_as_string(coder%context,slot2))) + trim(pm_type_as_string(coder%context,slot2))) call more_error(coder%context,'Parameter type constraint: '//& - trim(pm_typ_as_string(coder%context,t%data%i(t%offset)))) + trim(pm_type_as_string(coder%context,t%data%i(t%offset)))) call infer_trace(coder) endif slot=slot2 @@ -1516,9 +1516,9 @@ subroutine prc_call(coder,cblock,callnode,base) call infer_error(coder,callnode,& 'Keyword argument type mismatch:',t) call more_error(coder%context,'Mismatched argument: '//& - trim(pm_typ_as_string(coder%context,slot2))) + trim(pm_type_as_string(coder%context,slot2))) call more_error(coder%context,'Mismatched parameter: '//& - trim(pm_typ_as_string(coder%context,slot))) + trim(pm_type_as_string(coder%context,slot))) call infer_trace(coder) endif endif @@ -1548,7 +1548,7 @@ subroutine prc_call(coder,cblock,callnode,base) if(coder%first_pass) then if(arg_type_with_mode(1)>0) then call cnode_error(coder,callnode,'Type inference gives: '//& - trim(pm_typ_as_string(coder%context,arg_type_with_mode(1))),warn=.true.) + trim(pm_type_as_string(coder%context,arg_type_with_mode(1))),warn=.true.) else call cnode_error(coder,callnode,'Type inference fails',warn=.true.) endif @@ -1599,7 +1599,7 @@ subroutine get_arg_types_and_modes if(coder%wtop+nargs+2>max_code_stack) then call pm_panic('Program too complex') endif - coder%wstack(coder%wtop+1)=pm_typ_is_tuple + coder%wstack(coder%wtop+1)=pm_type_is_tuple coder%wstack(coder%wtop+2)=0 do i=1,nargs coder%wstack(coder%wtop+i+2)=arg_type_with_mode(nret+i) @@ -1638,7 +1638,7 @@ function arg_type(m) result(tno) integer,intent(in):: m integer:: tno integer:: mode - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(m),mode) + tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) end function arg_type @@ -1725,7 +1725,7 @@ subroutine check_logical(m) tno/=coder%true_name.and.tno/=coder%false_name) then call infer_error_with_trace(coder,callnode,& 'Expecting boolean expression, got: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) endif endif end subroutine check_logical @@ -1745,7 +1745,7 @@ subroutine check_long(m) if(tno/=pm_long) then call infer_error_with_trace(coder,callnode,& 'Expecting long expression, got: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) endif endif end subroutine check_long @@ -1773,9 +1773,9 @@ end function cblock_marked subroutine flag_import_export(tno) integer,intent(in):: tno integer:: tkind - tkind=pm_typ_kind(coder%context,tno) + tkind=pm_type_kind(coder%context,tno) call set_call_sig(& - merge(1,0,tkind/=pm_typ_is_dref.and.tkind/=pm_typ_is_vect)) + merge(1,0,tkind/=pm_type_is_dref.and.tkind/=pm_type_is_vect)) end subroutine flag_import_export !================================================================== @@ -1789,7 +1789,7 @@ end subroutine set_call_sig !================================================================== ! Resolve signature for item.name ! This is either 2.. for regular structures/records - ! or pm_typ_dref_offset + 2 .. for offset into a dref + ! or pm_type_dref_offset + 2 .. for offset into a dref ! (starting at 2 is for historical reasons and is horrible) !================================================================== recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) @@ -1802,7 +1802,7 @@ recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) type(pm_ptr):: svec base=coder%wtop - sig=pm_typ_find_elem(coder%context,tno,name,isref,& + sig=pm_type_find_elem(coder%context,tno,name,isref,& coder%wstack,coder%wtop,max_code_stack,elem_type,einfo) if(sig<0) then key(1)=-name @@ -1823,8 +1823,8 @@ recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) 'Error accessing element "'//& trim(pm_name_as_string(coder%context,name))//& '" of type "'//& - trim(pm_typ_as_string(coder%context,tno))//'"') - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno))//'"') + call pm_type_error(coder%context,einfo) endif elem_type=error_type endif @@ -1866,8 +1866,8 @@ subroutine combine_types(vararg,typ) call cnode_error(coder,var,'Variable changed type:',& cnode_get(var,var_name)) call more_error(coder%context,& - trim(pm_typ_as_string(coder%context,typ))//' <> '//& - trim(pm_typ_as_string(coder%context,typ0))) + trim(pm_type_as_string(coder%context,typ))//' <> '//& + trim(pm_type_as_string(coder%context,typ0))) endif end subroutine combine_types @@ -1904,7 +1904,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) proclist=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) nkey=cnode_get_num(callnode,call_nkeys) nextra=0 - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) call check_wstack(coder,nargs) undef_arg=.false. @@ -1922,16 +1922,16 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) if(cnode_get_kind(arg)==cnode_is_var) then if(cnode_get_num(arg,var_par_depth)==pdepth) then coder%wstack(coder%wtop+i)=& - pm_typ_replace_mode(coder%context,& + pm_type_replace_mode(coder%context,& coder%wstack(coder%wtop+i),& sym_shared,.false.) endif endif ! In an unlabelled conditional context, set coherent to partial if(is_unlabelled.and.& - pm_typ_get_mode(coder%context,coder%wstack(coder%wtop+i))==sym_coherent) then + pm_type_get_mode(coder%context,coder%wstack(coder%wtop+i))==sym_coherent) then coder%wstack(coder%wtop+i)=& - pm_typ_replace_mode(coder%context,& + pm_type_replace_mode(coder%context,& coder%wstack(coder%wtop+i),& sym_partial,.false.) endif @@ -1941,7 +1941,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) if(cnode_get_kind(cnode_arg(args,i+nret))==cnode_is_var) then if(.not.cnode_flags_set(cnode_arg(args,i+nret),var_flags,var_is_imported)) then coder%wstack(coder%wtop+i)=& - pm_typ_replace_mode(coder%context,& + pm_type_replace_mode(coder%context,& coder%wstack(coder%wtop+i),& sym_shared,.false.) endif @@ -1965,7 +1965,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) if(debug_inference) then do i=1,nargs write(*,*) 'PRE-STRIPPED',& - trim(pm_typ_as_string(coder%context,coder%wstack(coder%wtop+i))) + trim(pm_type_as_string(coder%context,coder%wstack(coder%wtop+i))) enddo endif @@ -1973,7 +1973,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ignore_rules=ignore_rules.or.cnode_get_name(callnode,cnode_modl_name)==sym_pm_system ! Implement mode combination rule for standard procedures - mode=pm_typ_combine_modes(coder%context,& + mode=pm_type_combine_modes(coder%context,& coder%wstack(coder%wtop+1:coder%wtop+nargs),& ignore_rules.or.run_shared,is_complete,is_cond,is_unlabelled) if(mode<0) then @@ -2011,16 +2011,16 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) if(.not.pm_fast_isnull(amps).and..not.ignore_rules) then amps=pm_name_val(coder%context,int(amps%offset)) do i=0,pm_fast_esize(amps) - tno2=pm_typ_strip_mode(coder%context,& + tno2=pm_type_strip_mode(coder%context,& coder%wstack(coder%wtop+amps%data%i(amps%offset+i)+nkey),mode2) if(tno2>0) then - tv=pm_typ_vect(coder%context,tno2) - if(pm_tv_kind(tv)==pm_typ_is_dref) then + tv=pm_type_vect(coder%context,tno2) + if(pm_tv_kind(tv)==pm_type_is_dref) then do while(pm_tv_name(tv)>0) tno2=pm_tv_arg(tv,2) - tv=pm_typ_vect(coder%context,tno2) + tv=pm_type_vect(coder%context,tno2) enddo - if(pm_tv_kind(tv)==pm_typ_is_dref.and.& + if(pm_tv_kind(tv)==pm_type_is_dref.and.& pm_tv_name(tv)/=pm_dref_is_ref) then call call_error(& 'Cannot pass a mixed-mode reference as an "&" argument - must use "&&"') @@ -2052,7 +2052,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! As this is standard call strip argument modes before passing do i=1,nargs coder%wstack(coder%wtop+i)=& - pm_typ_strip_mode(coder%context,coder%wstack(coder%wtop+i),mode2) + pm_type_strip_mode(coder%context,coder%wstack(coder%wtop+i),mode2) enddo endif @@ -2062,8 +2062,8 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! Deal with arg... if(cnode_flags_set(callnode,call_flags,call_is_vararg)) then if(top_word(coder)>0) then - t=pm_typ_vect(coder%context,top_word(coder)) - if(pm_tv_kind(t)==pm_typ_is_tuple) then + t=pm_type_vect(coder%context,top_word(coder)) + if(pm_tv_kind(t)==pm_type_is_tuple) then call drop_word(coder) do i=1,pm_tv_numargs(t) tno2=pm_tv_arg(t,i) @@ -2100,7 +2100,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! Apply return mode to returned values if(mode/=sym_coherent) then do j=1,nret - coder%stack(get_slot(j))=pm_typ_replace_mode(coder%context,& + coder%stack(get_slot(j))=pm_type_replace_mode(coder%context,& coder%stack(get_slot(j)),mode,is_cond) enddo endif @@ -2110,7 +2110,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) if(debug_inference) then do j=1,nret write(*,*) 'RETURN',j,& - trim(pm_typ_as_string(coder%context,coder%stack(get_slot(j)))) + trim(pm_type_as_string(coder%context,coder%stack(get_slot(j)))) enddo endif coder%wtop=coder%wtop-nargs-2 @@ -2134,7 +2134,7 @@ function arg_type(m) result(tno) integer,intent(in):: m integer:: tno integer:: mode - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(m),mode) + tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) end function arg_type !=================================================================== @@ -2227,8 +2227,8 @@ subroutine combine_types(vararg,typ) call cnode_error(coder,var,'Variable changed type:',& cnode_get(var,var_name)) call more_error(coder%context,& - trim(pm_typ_as_string(coder%context,typ))//' <> '//& - trim(pm_typ_as_string(coder%context,typ0))) + trim(pm_type_as_string(coder%context,typ))//' <> '//& + trim(pm_type_as_string(coder%context,typ0))) endif end subroutine combine_types @@ -2266,16 +2266,16 @@ function var_call(prlist,callsig) result(k) enddo return endif - tv=pm_typ_vect(coder%context,tno) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(coder%context,tno) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then tno=pm_tv_arg(tv,1) - tv=pm_typ_vect(coder%context,tno) + tv=pm_type_vect(coder%context,tno) endif coder%wstack(coder%wtop-nargs)=tno - if(pm_tv_kind(tv)/=pm_typ_is_proc) then + if(pm_tv_kind(tv)/=pm_type_is_proc) then call infer_error_with_trace(coder,callnode,& 'Value does not hold proc name; got: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) do i=1,nret call set_arg_to_error_type(i) enddo @@ -2294,7 +2294,7 @@ function var_call(prlist,callsig) result(k) rsig=simple_proc_call(sig,pr,issig=.true.) else tno2=pm_tv_arg(tv,1) - tv2=pm_typ_vect(coder%context,tno2) + tv2=pm_type_vect(coder%context,tno2) rsig=simple_proc_call(sig,pr,sigpars=pm_tv_arg(tv2,1),& sigtyp=tno,issig=.true.) if(rsig>0) call check_call_against_sig(tno,tv,callsig) @@ -2319,10 +2319,10 @@ subroutine check_call_against_sig(tno,tvp,callsig) type(pm_ptr),intent(in):: tvp,callsig integer:: tno2,i,k,tno3 type(pm_ptr):: tv,tv2,tv3,amplocs - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo integer:: nret,flags,n,mode,argmode - tv=pm_typ_vect(coder%context,pm_tv_arg(tvp,1)) + tv=pm_type_vect(coder%context,pm_tv_arg(tvp,1)) ! Get information on call i=callsig%offset+pm_fast_esize(callsig) @@ -2335,7 +2335,7 @@ subroutine check_call_against_sig(tno,tvp,callsig) if(name/=sym_pct) then call infer_error(coder,callnode,& 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) + pm_type_as_string(coder%context,tno)) call more_error(coder%context,& 'Expecting communicating "%" procedure') goto 10 @@ -2343,7 +2343,7 @@ subroutine check_call_against_sig(tno,tvp,callsig) elseif(name/=sym_proc) then call infer_error(coder,callnode,& 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) + pm_type_as_string(coder%context,tno)) call more_error(coder%context,& 'Not expecting communicating "%" procedure') goto 10 @@ -2351,29 +2351,29 @@ subroutine check_call_against_sig(tno,tvp,callsig) ! Check returns tno2=pm_tv_arg(tv,2) - tv2=pm_typ_vect(coder%context,tno2) + tv2=pm_type_vect(coder%context,tno2) n=pm_tv_numargs(tv2) if(nret/=n) then call infer_error(coder,callnode,& 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) + pm_type_as_string(coder%context,tno)) call more_error(coder%context,'Different number of return values') goto 10 endif do i=1,n - if(.not.pm_typ_includes(coder%context,pm_tv_arg(tv2,i),& - arg_type(i),pm_typ_incl_val,einfo)) then + if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& + arg_type(i),pm_type_incl_val,einfo)) then !!!! Check conversion to interface/proc_sig call infer_error(coder,callnode,& 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) + pm_type_as_string(coder%context,tno)) call more_error(coder%context,& 'Return type mismatch: '//& - trim(pm_typ_as_string(coder%context,pm_tv_arg(tv2,i)))//& + trim(pm_type_as_string(coder%context,pm_tv_arg(tv2,i)))//& ' vs: '//& - trim(pm_typ_as_string(coder%context,arg_type(i)))) + trim(pm_type_as_string(coder%context,arg_type(i)))) endif enddo @@ -2382,7 +2382,7 @@ subroutine check_call_against_sig(tno,tvp,callsig) call infer_error(coder,callnode,& 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) + pm_type_as_string(coder%context,tno)) call infer_trace(coder) end subroutine check_call_against_sig @@ -2410,7 +2410,7 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) logical:: ok,found,visible,found_has_no_rtypes integer:: save_proc_key_base,save_par_kind,save_par_kind2 type(pm_ptr):: keynames - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo integer,dimension(1):: key integer:: memo @@ -2447,11 +2447,11 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) ! If this call is for a proc signature, then restrict matching to that signature if(present(sigpars)) then - if(pm_typ_includes(coder%context,& - pars,sigpars,pm_typ_incl_typ,einfo)) then + if(pm_type_includes(coder%context,& + pars,sigpars,pm_type_incl_type,einfo)) then mpars=sigpars - elseif(pm_typ_includes(coder%context,& - sigpars,pars,pm_typ_incl_typ,einfo)) then + elseif(pm_type_includes(coder%context,& + sigpars,pars,pm_type_incl_type,einfo)) then mpars=pars else cycle @@ -2464,7 +2464,7 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) write(*,*) 'CHECKING SIG',(i-1)/2,& ' OF ',(cnode_numargs(procs)-2)/2,& ' FOR>',trim(sig_name_str(coder,int(sig))) - write(*,*) '>> ',trim(pm_typ_as_string(coder%context,pars)) + write(*,*) '>> ',trim(pm_type_as_string(coder%context,pars)) endif wbase=coder%wtop @@ -2478,8 +2478,8 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) ! If this is a second (or later) match, then check for compatibility if(found) then - if(pm_typ_includes(coder%context,pars,& - match_pars,pm_typ_incl_typ,einfo)) then + if(pm_type_includes(coder%context,pars,& + match_pars,pm_type_incl_type,einfo)) then coder%wtop=wbase coder%vtop=vbase ! Have to also check compatibility of return types @@ -2487,12 +2487,12 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) ! and the first-match procedure does not define them if(nret>0.and.rt>0.and.found_has_no_rtypes) then rt2=abs(cnode_get_num(cnode_arg(procs,i+1),pr_rtype)) - if(pm_typ_kind(coder%context,rt2)/=pm_typ_is_undef_result) then - if(.not.pm_typ_includes(coder%context,rt2,rt,pm_typ_incl_typ,einfo)) then + if(pm_type_kind(coder%context,rt2)/=pm_type_is_undef_result) then + if(.not.pm_type_includes(coder%context,rt2,rt,pm_type_incl_type,einfo)) then call infer_error(coder,proc,& 'Procedure returns type(s) not compatible'//& ' with an enclosing procedure to which it conforms') - call pm_typ_error(coder%context,einfo) + call pm_type_error(coder%context,einfo) call infer_error(coder,cnode_arg(procs,i+1),& 'Enclosing procedure referenced in above error') call more_error(coder%context,' ') @@ -2530,8 +2530,8 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) match_pars=pars proc=cnode_arg(procs,i+1) found_has_no_rtypes=& - pm_typ_kind(coder%context,cnode_get_num(proc,pr_rtype))==& - pm_typ_is_undef_result + pm_type_kind(coder%context,cnode_get_num(proc,pr_rtype))==& + pm_type_is_undef_result if(cnode_get_kind(proc)==cnode_is_builtin) then rt=prc_builtin(coder,proc,apars,pars,base) else @@ -2570,8 +2570,8 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) if(nret>0) then if(rt>0) then - rtvect=pm_typ_vect(coder%context,rt) - if(pm_tv_kind(rtvect)==pm_typ_is_tuple) then + rtvect=pm_type_vect(coder%context,rt) + if(pm_tv_kind(rtvect)==pm_type_is_tuple) then do j=1,nret v=cnode_arg(args,j) call combine_types(v,& @@ -2618,7 +2618,7 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) coder%wtop=m if(present(sigtyp)) then call more_error(coder%context,'Matching: '//& - trim(pm_typ_as_string(coder%context,sigtyp))) + trim(pm_type_as_string(coder%context,sigtyp))) else call more_error(coder%context,'Procedures considered:') do m=3,cnode_numargs(procs),2 @@ -2742,24 +2742,24 @@ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) logical,intent(in):: conv_poly integer:: typ3 type(pm_ptr):: tv1,tv2 - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo typ3=-1 - tv1=pm_typ_vect(coder%context,typ1) - tv2=pm_typ_vect(coder%context,typ2) - if(pm_tv_kind(tv1)==pm_typ_is_poly) then - if(pm_tv_kind(tv2)==pm_typ_is_poly) then - if(conv_poly.and.pm_typ_includes(coder%context,& + tv1=pm_type_vect(coder%context,typ1) + tv2=pm_type_vect(coder%context,typ2) + if(pm_tv_kind(tv1)==pm_type_is_poly) then + if(pm_tv_kind(tv2)==pm_type_is_poly) then + if(conv_poly.and.pm_type_includes(coder%context,& pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_typ_incl_typ,einfo)) then + pm_type_incl_type,einfo)) then if(add_poly_to_poly(coder,typ1,typ2)) then coder%types_finished=.false. endif typ3=typ1 endif else - if(pm_typ_includes(coder%context,& + if(pm_type_includes(coder%context,& pm_tv_arg(tv1,1),typ2,& - pm_typ_incl_typ,einfo)) then + pm_type_incl_type,einfo)) then if(add_type_to_poly(coder,typ1,typ2)) then coder%types_finished=.false. endif @@ -2860,27 +2860,27 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result type(pm_ptr):: pv,amb,av,vec integer:: i,rel,n,base,wbase,pk,pk2,dbase,status logical:: ok - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo if(pars==error_type) then tno=undefined return endif - pv=pm_typ_vect(coder%context,pars) + pv=pm_type_vect(coder%context,pars) pk=pm_tv_kind(pv) if(pm_debug_checks) then - if(pk/=pm_typ_is_tuple.and.& - pk/=pm_typ_is_vtuple) & + if(pk/=pm_type_is_tuple.and.& + pk/=pm_type_is_vtuple) & call pm_panic('check-sig') endif if(debug_inference) then write(*,*) 'Check call sig: (' - write(*,*) pars,' ',trim(pm_typ_as_string(coder%context,pars)) + write(*,*) pars,' ',trim(pm_type_as_string(coder%context,pars)) write(*,*) '----' do i=1,nargs at=coder%wstack(coder%wtop-nargs+i) - write(*,*) at,' ',trim(pm_typ_as_string(coder%context,at)) + write(*,*) at,' ',trim(pm_type_as_string(coder%context,at)) enddo write(*,*) ')' endif @@ -2892,7 +2892,7 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result ! Start building return type on wstack coder%wtop=coder%wtop+nargs+2 - coder%wstack(wbase+1)=pm_typ_is_tuple + coder%wstack(wbase+1)=pm_type_is_tuple coder%wstack(wbase+2)=0 n=pm_tv_numargs(pv) if(n+ignore>nargs) then @@ -2911,28 +2911,28 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result cycle endif if(i>n+ignore) then - if(pk/=pm_typ_is_vtuple) then + if(pk/=pm_type_is_vtuple) then tno=undefined goto 10 endif else pt=pm_tv_arg(pv,i-ignore) endif - if(pm_typ_includes(coder%context,& - pt,at,pm_typ_incl_val,einfo)) then + if(pm_type_includes(coder%context,& + pt,at,pm_type_incl_val,einfo)) then coder%wstack(wbase+i+2)=at if(debug_inference) then - write(*,*) 'Match',trim(pm_typ_as_string(coder%context,pt)),'<>',& - trim(pm_typ_as_string(coder%context,at)) + write(*,*) 'Match',trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) endif else - if(einfo%kind==pm_typ_err_ambig) then + if(einfo%kind==pm_type_err_ambig) then call cnode_error(coder,matchnode,& 'Ambiguous match to proc definition ( match in multiple alternatives)') call cnode_error(coder,callnode,'... call being processed') elseif(ipass>=1) then - pt2=pm_typ_strip_to_basic(coder%context,pt) - at2=pm_typ_convert(coder%context,pt2,at,.false.) + pt2=pm_type_strip_to_basic(coder%context,pt) + at2=pm_type_convert(coder%context,pt2,at,.false.) if(at2/=undefined) then coder%wstack(wbase+2+i)=at2 goto 5 @@ -2973,8 +2973,8 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result ! No match found if(debug_inference) then write(*,*) 'Does not include',& - trim(pm_typ_as_string(coder%context,pt)),'<>',& - trim(pm_typ_as_string(coder%context,at)) + trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) endif tno=undefined goto 10 @@ -2984,8 +2984,8 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result ! No match found (pass 1) if(debug_inference) then write(*,*) 'Does not include',& - trim(pm_typ_as_string(coder%context,pt)),'<>',& - trim(pm_typ_as_string(coder%context,at)) + trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) endif tno=undefined goto 10 @@ -2995,7 +2995,7 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result enddo ! Bundle arguments into a single type - tno=pm_new_typ(coder%context,coder%wstack(wbase+1:& + tno=pm_new_type(coder%context,coder%wstack(wbase+1:& wbase+nargs+2)) ! Error exit point @@ -3034,16 +3034,16 @@ function prc_cast(coder,node,tno1,tno2,isvar) result(k) integer:: k logical:: ok integer:: tno1b,tno3,base,status,key(1) - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo k=0 if(tno1<0.or.tno2<=0) then return endif - ok=pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_val,& + ok=pm_type_includes(coder%context,tno1,tno2,pm_type_incl_val,& einfo) if(.not.ok) then - tno1b=pm_typ_strip_to_basic(coder%context,tno1) - tno3=pm_typ_convert(coder%context,tno1b,tno2,.true.) + tno1b=pm_type_strip_to_basic(coder%context,tno1) + tno3=pm_type_convert(coder%context,tno1b,tno2,.true.) if(tno3==undefined) then base=coder%wtop call pm_indirect_include(coder%context,tno1,tno2,& @@ -3084,7 +3084,7 @@ function prc_cast(coder,node,tno1,tno2,isvar) result(k) if(.not.ok) then call infer_error(coder,node,& 'Value cannot be cast to the given type') - call pm_typ_error(coder%context,einfo) + call pm_type_error(coder%context,einfo) call infer_trace(coder) endif contains @@ -3411,7 +3411,7 @@ subroutine print_call_details(coder,node,base,numargs) signame=sig_name(coder,cnode_get_num(node,call_sig)) signamebase=pm_name_stem(coder%context,signame) if(signame==sym_proc) then - tv=pm_typ_vect(coder%context,coder%wstack(base)) + tv=pm_type_vect(coder%context,coder%wstack(base)) signame=abs(pm_tv_name(tv)) elseif(signamebase==sym_assignment.or.signamebase==sym_assign_var) then signame=sym_assign @@ -3428,13 +3428,13 @@ subroutine print_call_details(coder,node,base,numargs) call more_error(coder%context,' '//trim(pm_name_as_string(coder%context,& signame))//'%(') call more_error(coder%context,' region: '//& - trim(pm_typ_as_string(coder%context,& + trim(pm_type_as_string(coder%context,& coder%wstack(base+nkeys+1),distr=.true.))) call more_error(coder%context,' schedule: '//& - trim(pm_typ_as_string(coder%context,& + trim(pm_type_as_string(coder%context,& coder%wstack(base+nkeys+2),distr=.true.))) call more_error(coder%context,' here: '//& - trim(pm_typ_as_string(coder%context,& + trim(pm_type_as_string(coder%context,& coder%wstack(base+nkeys+3),distr=.true.))) n=3 endif @@ -3447,7 +3447,7 @@ subroutine print_call_details(coder,node,base,numargs) call check_amp(i-nkeys) call more_error(coder%context,& ' '//ampstr//& - trim(pm_typ_as_string(coder%context,coder%wstack(base+i)))//join) + trim(pm_type_as_string(coder%context,coder%wstack(base+i)))//join) enddo if(.not.present(numargs).and.cnode_flags_set(node,call_flags,call_is_vararg)) then call more_error(coder%context,' ...') @@ -3466,7 +3466,7 @@ subroutine print_call_details(coder,node,base,numargs) if(coder%wstack(base+i)/=pm_tiny_int) then call more_error(coder%context,' '//& trim(pm_name_as_string(coder%context,int(name%offset)))//'='//& - trim(pm_typ_as_string(coder%context,coder%wstack(base+i)))//join) + trim(pm_type_as_string(coder%context,coder%wstack(base+i)))//join) endif enddo @@ -3545,16 +3545,16 @@ subroutine print_proc_details(coder,node,sig,iscomm,tno) n=len_trim(str)+1 if(.not.iscomm) then if(pm_fast_isnull(amp)) then - str(n:)=pm_typ_as_string(coder%context,tno) + str(n:)=pm_type_as_string(coder%context,tno) else - tv=pm_typ_vect(coder%context,tno) + tv=pm_type_vect(coder%context,tno) nargs=pm_tv_numargs(tv) nx=0 if(add_char('(')) goto 777 do i=1,nargs call check_amp typ=pm_tv_arg(tv,i) - call typ_to_str(coder%context,typ,str,n,.false.) + call pm_type_to_string(coder%context,typ,str,n,.false.) if(n>len(str)-10) goto 777 if(ilen(str)-10) goto 777 @@ -3589,7 +3589,7 @@ subroutine print_proc_details(coder,node,sig,iscomm,tno) do i=4,nargs call check_amp typ=pm_tv_arg(tv,i) - call typ_to_str(coder%context,typ,str,n,.false.) + call pm_type_to_string(coder%context,typ,str,n,.false.) if(n>len(str)-10) goto 777 if(ipm_register(context,'main',root_module,module_dict,visibility,& @@ -285,9 +286,9 @@ subroutine run_type_inference(coder) !pm_opts%show_elems=.true. !pm_opts%show_variants=.true. do i=1,pm_dict_size(context,context%tcache) - write(4,*) 'TYPE',i,pm_typ_kind(context,i) - write(4,*) i,trim(pm_typ_as_string(context,i)) - call pm_dump_tree(context,4,pm_typ_val(context,i),2) + write(4,*) 'TYPE',i,pm_type_kind(context,i) + write(4,*) i,trim(pm_type_as_string(context,i)) + call pm_dump_tree(context,4,pm_type_val(context,i),2) call dump_type(context,4,i) write(4,*) 'DONE',i enddo diff --git a/src/parser.f90 b/src/parser.f90 index 922a59d..a1c6513 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -75,7 +75,6 @@ module pm_parser integer,parameter:: typ_ins=node_args+6 integer,parameter:: typ_includes=node_args+7 integer,parameter:: typ_num_args=8 - integer,parameter:: typ_interface=node_args+8 ! Proc parse nodes integer,parameter:: proc_name=node_args @@ -5091,12 +5090,6 @@ function type_decl(parser) result(iserr) elseif(parser%sym==sym_unique) then if(unique(parser,name)) goto 999 m=1 - elseif(parser%sym==sym_interface) then - call push_null_val(parser) - if(interface(parser,name,params)) goto 999 - m=0 - nextra=1 - sym=sym_interface else ! "type_list | ...type_list | type_list ..." sym=sym_includes @@ -5332,7 +5325,7 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) flags=0 if(parser%sym==sym_caret) then call scan(parser) - flags=pm_typ_is_soa + flags=pm_type_is_soa endif if(parser%sym==sym_open_brace) then call scan(parser) @@ -5396,7 +5389,7 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) call push_num_val(parser,nargs) call push_val(parser,params) call push_null_val(parser) - if(hasuse) flags=ior(flags,pm_typ_has_embedded) + if(hasuse) flags=ior(flags,pm_type_has_embedded) call push_num_val(parser,flags) call make_node(parser,sym,7) if(expect(parser,sym_close_brace)) return @@ -5407,7 +5400,7 @@ end function structrec !====================================================== ! Method definition proc name(...) { ... } - ! in struct, rec or interface + ! in struct, rec !====================================================== recursive function method(parser,typname,params,base) result(iserr) type(parse_state),intent(inout):: parser @@ -5448,58 +5441,6 @@ recursive function method(parser,typname,params,base) result(iserr) iserr=.false. end function method - !====================================================== - ! interface { ... } - !====================================================== - recursive function interface(parser,tname,params) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(in):: tname - type(pm_ptr),intent(in):: params - logical:: iserr - logical isvar - integer:: i,m,base,vbase,name,line,pos - type(pm_ptr):: tag - call get_sym_pos(parser,line,pos) - iserr=.true. - call scan(parser) - if(expect(parser,sym_open_brace)) return - base=parser%top - vbase=parser%vtop - call make_qualified_name(parser,tname) - tag=pop_val(parser) - call push_sym(parser,int(tag%offset)) - do - if(parser%sym==sym_proc) then - call scan(parser) - if(check_name_no_repeat(parser,name,base+1)) then - call push_sym(parser,name) - else - call parse_error(parser,'Expected method name') - return - endif - if(proctyp(parser,tname,params)) return - else - isvar=parser%sym==sym_var - if(isvar.or.parser%sym==sym_const) call scan(parser) - if(check_name_no_repeat(parser,name,base+1)) then - call push_sym(parser,merge(-name,name,isvar)) - else - call parse_error(parser,'Expected element name') - return - endif - if(expect(parser,sym_colon)) return - if(typ(parser)) return - endif - if(parser%sym==sym_close_brace) exit - if(expect(parser,sym_comma)) return - enddo - call make_node(parser,sym_list,parser%vtop-vbase) - call name_vector(parser,base) - if(expect(parser,sym_close_brace)) return - call make_node_at(parser,sym_interface,2,line,pos) - iserr=.false. - end function interface - !====================================================== ! Parameter declarations diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index 31efde6..0273ca0 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -54,13 +54,14 @@ module pm_sysdefs integer,parameter:: proc_is_not_pure_each = 2**23 integer,parameter:: proc_has_vkeys = 2**24 integer,parameter:: proc_is_dcomm = 2**25 - integer,parameter:: proc_is_variant = 2**26 + integer,parameter:: proc_is_file = 2**26 integer,parameter:: proc_needs_par = 2**27 + integer,parameter:: proc_prints_out = 2**28 integer,parameter:: proc_taints = proc_is_impure & + proc_is_not_inlinable + proc_has_for & - + proc_is_not_pure_each + proc_is_variant & - + proc_needs_par + + proc_is_not_pure_each + proc_is_dcomm + proc_is_file & + + proc_needs_par + proc_prints_out contains @@ -5227,23 +5228,23 @@ subroutine sysdefs(parser) ! Built-in operators call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->sint,sint',& - op_open_file,0,line,proc_is_impure+proc_is_variant) + op_open_file,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_close_file(sint)->sint',& - op_close_file,0,line,proc_is_impure+proc_is_variant) + op_close_file,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_seek_file(sint,lint)->sint',& - op_seek_file,0,line,proc_is_impure+proc_is_variant) + op_seek_file,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_read_file(sint,&any)->sint',& - op_read_file,0,line,proc_is_impure+proc_is_variant) + op_read_file,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_write_file(sint,any)->sint',& - op_write_file,0,line,proc_is_impure+proc_is_variant) + op_write_file,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_read_file_array(sint,&any,int)->sint',& - op_read_file_array,0,line,proc_is_impure+proc_is_variant) + op_read_file_array,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_write_file_array(sint,any,int)->sint',& - op_write_file_array,0,line,proc_is_impure+proc_is_variant) + op_write_file_array,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->sint',& - op_read_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) + op_read_file_tile,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->sint',& - op_write_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) + op_write_file_tile,0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_io_error_string(sint)->string',& op_io_error_string,0,line,proc_is_impure) diff --git a/src/types.f90 b/src/types.f90 index db190cc..5e7b849 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -32,102 +32,102 @@ module pm_types use pm_options implicit none - logical,parameter:: pm_typ_extra_debug=.false. - integer,parameter:: pm_max_typ_args=128 + logical,parameter:: pm_type_extra_debug=.false. + integer,parameter:: pm_max_type_args=128 ! Flags for types - integer,parameter:: pm_typ_has_storage=32 - integer,parameter:: pm_typ_has_distributed=64 - integer,parameter:: pm_typ_has_array=128 - integer,parameter:: pm_typ_has_poly=256 - integer,parameter:: pm_typ_has_generic=512 - integer,parameter:: pm_typ_has_vect=1024 - integer,parameter:: pm_typ_has_embedded=2048 - integer,parameter:: pm_typ_has_params=4096 - integer,parameter:: pm_typ_is_soa=8192 - integer,parameter:: pm_typ_is_aos=16384 - integer,parameter:: pm_typ_is_seq=32768 - integer,parameter:: pm_typ_leaves=65536 + integer,parameter:: pm_type_has_storage=32 + integer,parameter:: pm_type_has_distributed=64 + integer,parameter:: pm_type_has_array=128 + integer,parameter:: pm_type_has_poly=256 + integer,parameter:: pm_type_has_generic=512 + integer,parameter:: pm_type_has_vect=1024 + integer,parameter:: pm_type_has_embedded=2048 + integer,parameter:: pm_type_has_params=4096 + integer,parameter:: pm_type_is_soa=8192 + integer,parameter:: pm_type_is_aos=16384 + integer,parameter:: pm_type_is_seq=32768 + integer,parameter:: pm_type_leaves=65536 ! Bitwise-or of flags which are not taints (only one so far) - integer,parameter:: pm_typ_flags_untainting = pm_typ_has_embedded + integer,parameter:: pm_type_flags_untainting = pm_type_has_embedded ! Type kind + default flags - integer,parameter:: pm_typ_new_user=1 - integer,parameter:: pm_typ_new_struct=2 - integer,parameter:: pm_typ_new_rec=3 - integer,parameter:: pm_typ_new_array=4+pm_typ_has_array - integer,parameter:: pm_typ_new_tuple=5 - integer,parameter:: pm_typ_new_vtuple=6 - integer,parameter:: pm_typ_new_single_name=7 - integer,parameter:: pm_typ_new_proc=8 - integer,parameter:: pm_typ_new_all=9 - integer,parameter:: pm_typ_new_any=10+pm_typ_has_generic - integer,parameter:: pm_typ_new_poly=11+pm_typ_has_poly+& - pm_typ_has_storage - integer,parameter:: pm_typ_new_value=12 - integer,parameter:: pm_typ_new_contains=13 - integer,parameter:: pm_typ_new_const=14+pm_typ_has_storage - integer,parameter:: pm_typ_new_dref=15 - integer,parameter:: pm_typ_new_par_kind=16 - integer,parameter:: pm_typ_new_proc_sig=17 - integer,parameter:: pm_typ_new_undef_result=18 - integer,parameter:: pm_typ_new_interface=19 - integer,parameter:: pm_typ_new_except=20 - integer,parameter:: pm_typ_new_param=21+pm_typ_has_params - integer,parameter:: pm_typ_new_amp=22 - integer,parameter:: pm_typ_new_has=23 - integer,parameter:: pm_typ_new_vect=24+pm_typ_has_vect - integer,parameter:: pm_typ_new_params=25 - integer,parameter:: pm_typ_new_type=26 - integer,parameter:: pm_typ_new_enveloped=27 - integer,parameter:: pm_typ_new_bottom=28 - integer,parameter:: pm_typ_new_includes=29 + integer,parameter:: pm_type_new_user=1 + integer,parameter:: pm_type_new_struct=2 + integer,parameter:: pm_type_new_rec=3 + integer,parameter:: pm_type_new_array=4+pm_type_has_array + integer,parameter:: pm_type_new_tuple=5 + integer,parameter:: pm_type_new_vtuple=6 + integer,parameter:: pm_type_new_single_name=7 + integer,parameter:: pm_type_new_proc=8 + integer,parameter:: pm_type_new_all=9 + integer,parameter:: pm_type_new_any=10+pm_type_has_generic + integer,parameter:: pm_type_new_poly=11+pm_type_has_poly+& + pm_type_has_storage + integer,parameter:: pm_type_new_value=12 + integer,parameter:: pm_type_new_contains=13 + integer,parameter:: pm_type_new_const=14+pm_type_has_storage + integer,parameter:: pm_type_new_dref=15 + integer,parameter:: pm_type_new_par_kind=16 + integer,parameter:: pm_type_new_proc_sig=17 + integer,parameter:: pm_type_new_undef_result=18 + !integer,parameter:: pm_type_new_interface=19 + integer,parameter:: pm_type_new_except=20 + integer,parameter:: pm_type_new_param=21+pm_type_has_params + integer,parameter:: pm_type_new_amp=22 + integer,parameter:: pm_type_new_has=23 + integer,parameter:: pm_type_new_vect=24+pm_type_has_vect + integer,parameter:: pm_type_new_params=25 + integer,parameter:: pm_type_new_type=26 + integer,parameter:: pm_type_new_enveloped=27 + integer,parameter:: pm_type_new_bottom=28 + integer,parameter:: pm_type_new_includes=29 ! Type kinds - integer,parameter:: pm_typ_is_basic=0 - integer,parameter:: pm_typ_is_user=1 - integer,parameter:: pm_typ_is_struct=2 - integer,parameter:: pm_typ_is_rec=3 - integer,parameter:: pm_typ_is_array=4 - integer,parameter:: pm_typ_is_tuple=5 - integer,parameter:: pm_typ_is_vtuple=6 - integer,parameter:: pm_typ_is_single_name=7 - integer,parameter:: pm_typ_is_proc=8 - integer,parameter:: pm_typ_is_all=9 - integer,parameter:: pm_typ_is_any=10 - integer,parameter:: pm_typ_is_poly=11 - integer,parameter:: pm_typ_is_value=12 - integer,parameter:: pm_typ_is_contains=13 - integer,parameter:: pm_typ_is_const=14 - integer,parameter:: pm_typ_is_dref=15 - integer,parameter:: pm_typ_is_par_kind=16 - integer,parameter:: pm_typ_is_proc_sig=17 - integer,parameter:: pm_typ_is_undef_result=18 - integer,parameter:: pm_typ_is_interface=19 - integer,parameter:: pm_typ_is_except=20 - integer,parameter:: pm_typ_is_param=21 - integer,parameter:: pm_typ_is_amp=22 - integer,parameter:: pm_typ_is_has=23 - integer,parameter:: pm_typ_is_vect=24 - integer,parameter:: pm_typ_is_params=25 - integer,parameter:: pm_typ_is_type=26 - integer,parameter:: pm_typ_is_enveloped=27 - integer,parameter:: pm_typ_is_bottom=28 - integer,parameter:: pm_typ_is_includes=29 - - integer,parameter:: pm_typ_kind_mask=31 - integer,parameter:: pm_typ_max_leaves=255 + integer,parameter:: pm_type_is_basic=0 + integer,parameter:: pm_type_is_user=1 + integer,parameter:: pm_type_is_struct=2 + integer,parameter:: pm_type_is_rec=3 + integer,parameter:: pm_type_is_array=4 + integer,parameter:: pm_type_is_tuple=5 + integer,parameter:: pm_type_is_vtuple=6 + integer,parameter:: pm_type_is_single_name=7 + integer,parameter:: pm_type_is_proc=8 + integer,parameter:: pm_type_is_all=9 + integer,parameter:: pm_type_is_any=10 + integer,parameter:: pm_type_is_poly=11 + integer,parameter:: pm_type_is_value=12 + integer,parameter:: pm_type_is_contains=13 + integer,parameter:: pm_type_is_const=14 + integer,parameter:: pm_type_is_dref=15 + integer,parameter:: pm_type_is_par_kind=16 + integer,parameter:: pm_type_is_proc_sig=17 + integer,parameter:: pm_type_is_undef_result=18 + !integer,parameter:: pm_type_is_interface=19 + integer,parameter:: pm_type_is_except=20 + integer,parameter:: pm_type_is_param=21 + integer,parameter:: pm_type_is_amp=22 + integer,parameter:: pm_type_is_has=23 + integer,parameter:: pm_type_is_vect=24 + integer,parameter:: pm_type_is_params=25 + integer,parameter:: pm_type_is_type=26 + integer,parameter:: pm_type_is_enveloped=27 + integer,parameter:: pm_type_is_bottom=28 + integer,parameter:: pm_type_is_includes=29 + + integer,parameter:: pm_type_kind_mask=31 + integer,parameter:: pm_type_max_leaves=255 ! Mode for type inclusion testing (type<>value,type<>type,type==type) - integer,parameter:: pm_typ_incl_val=1 - integer,parameter:: pm_typ_incl_typ=2 - integer,parameter:: pm_typ_incl_equiv=4 - integer,parameter:: pm_typ_incl_indirect=8 - integer,parameter:: pm_typ_incl_nomatch=16 - integer,parameter:: pm_typ_incl_extract=32 + integer,parameter:: pm_type_incl_val=1 + integer,parameter:: pm_type_incl_type=2 + integer,parameter:: pm_type_incl_equiv=4 + integer,parameter:: pm_type_incl_indirect=8 + integer,parameter:: pm_type_incl_nomatch=16 + integer,parameter:: pm_type_incl_extract=32 - integer,parameter:: pm_typ_dref_offset=2000 + integer,parameter:: pm_type_dref_offset=2000 ! Return from struct/rec element lookup integer,parameter:: pm_elem_found=0 @@ -135,30 +135,22 @@ module pm_types integer,parameter:: pm_elem_clash=2 ! Information on location and kind of non-match/type error - type pm_typ_einfo + type pm_type_einfo integer:: kind integer:: index integer:: name,vname,typ1,typ2,vtyp1,vtyp2 - end type pm_typ_einfo + end type pm_type_einfo ! Error codes from type testing - integer,parameter:: pm_typ_err_none=0 - integer,parameter:: pm_typ_err_elem=1 - integer,parameter:: pm_typ_err_param=2 - integer,parameter:: pm_typ_err_ambig=4 - integer,parameter:: pm_typ_err_not_set=8 - integer,parameter:: pm_typ_err_interface=16 - integer,parameter:: pm_typ_err_interface_clash=32 - integer,parameter:: pm_typ_err_interface_mismatch=64 - integer,parameter:: pm_typ_err_interface_bad_typ=128 - integer,parameter:: pm_typ_err_interface_write=256 - integer,parameter:: pm_typ_err_interface_nesting=512 - integer,parameter:: pm_typ_err_interface_inconsistent=1024 - integer,parameter:: pm_typ_err_interface_elem=2048 - integer,parameter:: pm_typ_err_elem_clash=4096 - integer,parameter:: pm_typ_err_elem_not_found=8192 - integer,parameter:: pm_typ_err_elem_bad_typ=16384 - integer,parameter:: pm_typ_err_elem_not_in_interface=32768 + integer,parameter:: pm_type_err_none=0 + integer,parameter:: pm_type_err_elem=1 + integer,parameter:: pm_type_err_param=2 + integer,parameter:: pm_type_err_ambig=4 + integer,parameter:: pm_type_err_not_set=8 + integer,parameter:: pm_type_err_elem_clash=16 + integer,parameter:: pm_type_err_elem_not_found=32 + integer,parameter:: pm_type_err_elem_bad_type=64 + integer,parameter:: pm_type_err_elem_not_in_interface=128 ! Maximum nesting of "type is" declarations integer,private,parameter:: max_user_nesting = 64 @@ -196,7 +188,7 @@ module pm_types contains ! Initialise type system - subroutine init_typ(context) + subroutine pm_init_types(context) type(pm_context),pointer:: context integer:: i,j integer,dimension(2):: key @@ -218,7 +210,7 @@ subroutine init_typ(context) context%pcache=pm_dict_new(context,1024_pm_ln) context%vcache=pm_set_new(context,1024_pm_ln) - key(1)=pm_typ_is_basic + key(1)=pm_type_is_basic do i=1,pm_null key(2)=pm_intern(context,trim(base_types(i))) if(pm_debug_level>2) then @@ -226,9 +218,9 @@ subroutine init_typ(context) endif j=pm_idict_add(context,context%tcache,key,2,& pm_null_obj) - if(j/=i) call pm_panic('init_typ') + if(j/=i) call pm_panic('init_type') enddo - key(1)=pm_typ_is_basic+pm_typ_has_storage+pm_typ_leaves + key(1)=pm_type_is_basic+pm_type_has_storage+pm_type_leaves do i=pm_null+1,pm_last_sys_type key(2)=pm_intern(context,trim(base_types(i))) if(pm_debug_level>2) then @@ -236,9 +228,9 @@ subroutine init_typ(context) endif j=pm_idict_add(context,context%tcache,key,2,& pm_null_obj) - if(j/=i) call pm_panic('init_typ') + if(j/=i) call pm_panic('init_type') enddo - key(1)=pm_typ_is_user + key(1)=pm_type_is_user do i=1,pm_last_sys_type if(base_types(i)(1:1)/='<') then key(2)=pm_intern(context,trim(base_types(i))) @@ -249,7 +241,7 @@ subroutine init_typ(context) if(pm_debug_level>2) write(*,*) 'Types inited' contains include 'ftypeno.inc' - end subroutine init_typ + end subroutine pm_init_types !============================================================ ! Make type description node @@ -258,7 +250,7 @@ end subroutine init_typ ! - flags can be specified in an optional argument ! Val optional argument gives value associated with the type !============================================================ - function pm_new_basic_typ(context,arr,val,flags) result(tno) + function pm_new_basic_type(context,arr,val,flags) result(tno) type(pm_context),pointer:: context integer,dimension(:),intent(inout):: arr type(pm_ptr),intent(in),optional:: val @@ -276,7 +268,7 @@ function pm_new_basic_typ(context,arr,val,flags) result(tno) call pm_panic('bad kind') endif if(present(flags)) then - arr(1)=ior(arr(1),iand(flags,not(pm_typ_kind_mask+pm_typ_flags_untainting))) + arr(1)=ior(arr(1),iand(flags,not(pm_type_kind_mask+pm_type_flags_untainting))) endif k=pm_ivect_lookup(context,context%tcache, & arr,size(arr)) @@ -285,7 +277,7 @@ function pm_new_basic_typ(context,arr,val,flags) result(tno) tno=k contains include 'ftiny.inc' - end function pm_new_basic_typ + end function pm_new_basic_type !============================================================= ! Make type description record returning type number @@ -294,7 +286,7 @@ end function pm_new_basic_typ ! arr must contain type_kind type_name arg1 arg2 ... ! val optional argument gives value associated with the type !============================================================= - function pm_new_typ(context,arr,val) result(tno) + function pm_new_type(context,arr,val) result(tno) type(pm_context),pointer:: context integer,dimension(:),intent(inout):: arr type(pm_ptr),intent(in),optional:: val @@ -316,13 +308,13 @@ function pm_new_typ(context,arr,val) result(tno) tflags=0 nleaves=0 do k=3,size(arr) - flags=pm_typ_flags(context,arr(k)) + flags=pm_type_flags(context,arr(k)) tflags=ior(tflags,flags) - nleaves=max(nleaves+flags/pm_typ_leaves,pm_typ_max_leaves) + nleaves=max(nleaves+flags/pm_type_leaves,pm_type_max_leaves) enddo arr(1)=ior(arr(1),iand(tflags,& - iand(pm_typ_leaves-1,not(pm_typ_kind_mask+pm_typ_flags_untainting))))+& - nleaves*pm_typ_leaves + iand(pm_type_leaves-1,not(pm_type_kind_mask+pm_type_flags_untainting))))+& + nleaves*pm_type_leaves k=pm_ivect_lookup(context,context%tcache, & arr,size(arr)) if(k==0) k=pm_idict_add(context,context%tcache,& @@ -330,14 +322,14 @@ function pm_new_typ(context,arr,val) result(tno) tno=k contains include 'ftiny.inc' - end function pm_new_typ + end function pm_new_type !========================================================================== ! Associate a type with a name (not necessarily the same as the type name) ! Used by struct/rec declarations !========================================================================== - subroutine pm_typ_record_by_name(context,name,typ) + subroutine pm_type_record_by_name(context,name,typ) type(pm_context),pointer:: context integer,intent(in):: name,typ integer(pm_ln):: k @@ -348,13 +340,13 @@ subroutine pm_typ_record_by_name(context,name,typ) call pm_dict_set(context,context%pcache,key,val,.true.,.true.,ok) contains include 'ftiny.inc' - end subroutine pm_typ_record_by_name + end subroutine pm_type_record_by_name !============================================================================== ! Retrieve type associated with a given name (again not same as the type name) ! Used by struct/rec declarations !============================================================================== - function pm_typ_from_recorded_name(context,name) result(typ) + function pm_type_from_recorded_name(context,name) result(typ) type(pm_context),pointer:: context integer,intent(in):: name integer:: typ @@ -364,41 +356,41 @@ function pm_typ_from_recorded_name(context,name) result(typ) typ=val%offset contains include 'ftiny.inc' - end function pm_typ_from_recorded_name + end function pm_type_from_recorded_name !==================================================== ! New parameters type with n parameters !==================================================== - function pm_new_params_typ(context,n,typ) result(tno) + function pm_new_params_type(context,n,typ) result(tno) type(pm_context),pointer:: context integer,intent(in):: n,typ integer:: tno integer:: arr(3) - arr(1)=pm_typ_new_params + arr(1)=pm_type_new_params arr(2)=n arr(3)=typ - tno=pm_new_basic_typ(context,arr,& - flags=iand(pm_typ_flags(context,typ),not(pm_typ_has_params))) - end function pm_new_params_typ + tno=pm_new_basic_type(context,arr,& + flags=iand(pm_type_flags(context,typ),not(pm_type_has_params))) + end function pm_new_params_type !======================================= ! Create new user type with body tno2 !======================================= - function pm_new_user_typ(context,arr,tno2) result(tno) + function pm_new_user_type(context,arr,tno2) result(tno) type(pm_context),pointer:: context integer,dimension(:),intent(inout):: arr integer:: tno2 integer:: tno - tno=pm_new_basic_typ(context,arr,& + tno=pm_new_basic_type(context,arr,& val=pm_fast_typeno(context,tno2)) contains include 'ftypeno.inc' - end function pm_new_user_typ + end function pm_new_user_type !======================================== ! Create new array type: etyp[dtyp] !======================================== - function pm_new_arr_typ(context,kind,etyp,dtyp,styp) result(tno) + function pm_new_arr_type(context,kind,etyp,dtyp,styp) result(tno) type(pm_context),pointer:: context integer,intent(in):: kind integer,intent(in):: etyp @@ -407,256 +399,256 @@ function pm_new_arr_typ(context,kind,etyp,dtyp,styp) result(tno) integer:: tno integer,dimension(5):: args integer:: flags - flags=pm_typ_is_array+merge(pm_typ_has_array,0,kind/=sym_fix) + flags=pm_type_is_array+merge(pm_type_has_array,0,kind/=sym_fix) args(1)=flags args(2)=kind args(3)=etyp args(4)=dtyp args(5)=styp - tno=pm_new_typ(context,args) - end function pm_new_arr_typ + tno=pm_new_type(context,args) + end function pm_new_arr_type !========================= ! Create type a or b !========================= - function pm_typ_combine(context,a,b) result(tno) + function pm_type_combine(context,a,b) result(tno) type(pm_context),pointer:: context integer,intent(in):: a,b integer:: tno integer,dimension(4):: args - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo if(a==b) then tno=a return - elseif(pm_typ_includes(context,a,b,pm_typ_incl_typ,einfo)) then + elseif(pm_type_includes(context,a,b,pm_type_incl_type,einfo)) then tno=a return - elseif(pm_typ_includes(context,b,a,pm_typ_incl_typ,einfo)) then + elseif(pm_type_includes(context,b,a,pm_type_incl_type,einfo)) then tno=b return endif - args(1)=pm_typ_new_any + args(1)=pm_type_new_any args(2)=0 args(3)=a args(4)=b - tno=pm_new_typ(context,args) - end function pm_typ_combine + tno=pm_new_type(context,args) + end function pm_type_combine !========================================== ! Create new polymorphic type: @etype !========================================== - function pm_new_poly_typ(context,etyp) result(tno) + function pm_new_poly_type(context,etyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp integer:: tno integer,dimension(3):: args - args(1)=pm_typ_new_poly + args(1)=pm_type_new_poly args(2)=0 args(3)=etyp - tno=pm_new_basic_typ(context,args) - end function pm_new_poly_typ + tno=pm_new_basic_type(context,args) + end function pm_new_poly_type !========================================== ! Create new type-value type: !========================================== - function pm_new_type_typ(context,etyp) result(tno) + function pm_new_type_type(context,etyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp integer:: tno integer,dimension(3):: args - args(1)=pm_typ_new_type + args(1)=pm_type_new_type args(2)=0 args(3)=etyp - tno=pm_new_basic_typ(context,args) - end function pm_new_type_typ + tno=pm_new_basic_type(context,args) + end function pm_new_type_type !=============================================== ! Create new includes: type inc type !================================================ - function pm_new_includes_typ(context,etyp,mtyp) result(tno) + function pm_new_includes_type(context,etyp,mtyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp,mtyp integer:: tno integer,dimension(4):: args - args(1)=pm_typ_new_includes + args(1)=pm_type_new_includes args(2)=0 args(3)=etyp args(4)=mtyp - tno=pm_new_basic_typ(context,args) - end function pm_new_includes_typ + tno=pm_new_basic_type(context,args) + end function pm_new_includes_type !========================================== ! Create new compile time value type !========================================== - function pm_new_value_typ(context,val) result(tno) + function pm_new_value_type(context,val) result(tno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val integer:: tno integer,dimension(3):: args - args(1)=pm_typ_new_value + args(1)=pm_type_new_value args(2)=pm_set_add(context,context%vcache,val) args(3)=pm_fast_typeof(val) - tno=pm_new_basic_typ(context,args,val) + tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' - end function pm_new_value_typ + end function pm_new_value_type !============================================== ! Create new compile time name value type !============================================== - function pm_new_name_typ(context,name) result(tno) + function pm_new_name_type(context,name) result(tno) type(pm_context),pointer:: context integer,intent(in):: name integer:: tno integer,dimension(2):: args - args(1)=pm_typ_new_single_name + args(1)=pm_type_new_single_name if(pm_name_stem(context,name)==sym_distr_tag) then - args(1)=ior(args(1),pm_typ_has_distributed) + args(1)=ior(args(1),pm_type_has_distributed) endif args(2)=name - tno=pm_new_typ(context,args) - end function pm_new_name_typ + tno=pm_new_type(context,args) + end function pm_new_name_type !============================================= ! Create new compile time proc value type !============================================= - function pm_new_proc_typ(context,name) result(tno) + function pm_new_proc_type(context,name) result(tno) type(pm_context),pointer:: context integer,intent(in):: name integer:: tno integer,dimension(2):: args - args(1)=pm_typ_new_proc + args(1)=pm_type_new_proc args(2)=name - tno=pm_new_typ(context,args) - end function pm_new_proc_typ + tno=pm_new_type(context,args) + end function pm_new_proc_type !========================================== ! Create internal vector type ^^(T) !========================================== - function pm_new_vect_typ(context,tno) result(tno2) + function pm_new_vect_type(context,tno) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno integer:: tno2 integer,dimension(3):: args - args(1)=pm_typ_new_vect + args(1)=pm_type_new_vect args(2)=0 args(3)=tno - tno2=pm_new_typ(context,args) - end function pm_new_vect_typ + tno2=pm_new_type(context,args) + end function pm_new_vect_type !================================================= ! Change the value associated with a type ! (used for user and value types) !================================================= - subroutine pm_typ_set_val(context,tno,val) + subroutine pm_type_set_val(context,tno,val) type(pm_context),pointer:: context integer:: tno type(pm_ptr),intent(in):: val call pm_dict_set_val(context,context%tcache,int(tno,pm_ln),val) - end subroutine pm_typ_set_val + end subroutine pm_type_set_val !=================================== ! Return the kind of a given type !=================================== - function pm_typ_kind(context,tno) result(kind) + function pm_type_kind(context,tno) result(kind) type(pm_context),pointer:: context integer,intent(in):: tno integer:: kind if(tno<=0) then kind=0 else - kind=pm_tv_kind(pm_typ_vect(context,tno)) + kind=pm_tv_kind(pm_type_vect(context,tno)) endif - end function pm_typ_kind + end function pm_type_kind !========================================= ! Return flags for a given type !========================================= - function pm_typ_flags(context,tno) result(flags) + function pm_type_flags(context,tno) result(flags) type(pm_context),pointer:: context integer,intent(in):: tno integer:: flags integer:: tno2 type(pm_ptr):: tv if(tno==0) then - flags=pm_typ_has_generic + flags=pm_type_has_generic return else - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) flags=pm_tv_flags(tv) tno2=tno - do while(iand(flags,pm_typ_kind_mask)==pm_typ_is_user) + do while(iand(flags,pm_type_kind_mask)==pm_type_is_user) tv=pm_dict_val(context,context%tcache,int(tno2,pm_ln)) tno2=tv%offset if(tno2/=0) then - tv=pm_typ_vect(context,tno2) + tv=pm_type_vect(context,tno2) flags=pm_tv_flags(tv) else - flags=pm_typ_has_generic + flags=pm_type_has_generic endif enddo endif contains include 'fvkind.inc' - end function pm_typ_flags + end function pm_type_flags !================================================= ! Return number of leaves associated with a type !================================================= - function pm_typ_needs_storage(context,tno) result(ok) + function pm_type_needs_storage(context,tno) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno logical:: ok - ok=iand(pm_typ_flags(context,tno),pm_typ_has_storage)/=0 - end function pm_typ_needs_storage + ok=iand(pm_type_flags(context,tno),pm_type_has_storage)/=0 + end function pm_type_needs_storage !================================================= ! Return number of leaves associated with a type !================================================= - function pm_typ_num_leaves(context,tno) result(n) + function pm_type_num_leaves(context,tno) result(n) type(pm_context),pointer:: context integer,intent(in):: tno integer:: n - n=pm_typ_flags(context,tno)/pm_typ_leaves - end function pm_typ_num_leaves + n=pm_type_flags(context,tno)/pm_type_leaves + end function pm_type_num_leaves !================================================= ! Return argument #n of type tno !================================================= - function pm_typ_arg(context,tno,n) result(tno2) + function pm_type_arg(context,tno,n) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno,n integer:: tno2 type(pm_ptr):: tv - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tno2=pm_tv_arg(tv,n) - end function pm_typ_arg + end function pm_type_arg !================================================= ! Return name associated with type tno !================================================= - function pm_typ_name(context,tno) result(name) + function pm_type_name(context,tno) result(name) type(pm_context),pointer:: context integer,intent(in):: tno integer:: name type(pm_ptr):: tv - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) name=pm_tv_name(tv) - end function pm_typ_name + end function pm_type_name !===================================================== ! Return name of element #n associated with type tno !==============================---=================== - function pm_typ_elem_name(context,tno,n) result(name) + function pm_type_elem_name(context,tno,n) result(name) type(pm_context),pointer:: context integer,intent(in):: tno,n integer:: name,kind type(pm_ptr):: tv,namev - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) if(pm_debug_checks) then kind=pm_tv_kind(tv) - if(kind/=pm_typ_is_struct.and.kind/=pm_typ_is_rec) then + if(kind/=pm_type_is_struct.and.kind/=pm_type_is_rec) then write(*,*) 'tno=',tno,'kind=',kind call pm_panic('typ_elem_name not struct/rec') endif @@ -664,24 +656,24 @@ function pm_typ_elem_name(context,tno,n) result(name) name=pm_tv_name(tv) namev=pm_name_val(context,name) name=namev%data%i(namev%offset+n) - end function pm_typ_elem_name + end function pm_type_elem_name !========================================== ! Look up type and return number ! (returns zero if not found) !========================================== - function pm_typ_lookup(context,arr) result(tno) + function pm_type_lookup(context,arr) result(tno) type(pm_context),pointer:: context integer,dimension(:):: arr integer:: tno tno=pm_ivect_lookup(context,context%tcache, & arr,size(arr)) - end function pm_typ_lookup + end function pm_type_lookup !=============================================================== ! Look up user type and return type number it is defined to be !=============================================================== - function pm_user_typ_lookup(context,arr) result(tno) + function pm_user_type_lookup(context,arr) result(tno) type(pm_context),pointer:: context integer,dimension(:):: arr integer:: tno @@ -694,50 +686,50 @@ function pm_user_typ_lookup(context,arr) result(tno) else tno=-1 endif - end function pm_user_typ_lookup + end function pm_user_type_lookup !==================================================== ! Lookup parameterless user type with given name !==================================================== - function pm_user_typ_lookup_by_name(context,name) result(tno) + function pm_user_type_lookup_by_name(context,name) result(tno) type(pm_context),pointer:: context integer,intent(in):: name integer:: tno integer:: arr(2) - arr(1)=pm_typ_new_user + arr(1)=pm_type_new_user arr(2)=name - tno=pm_user_typ_lookup(context,arr) - end function pm_user_typ_lookup_by_name + tno=pm_user_type_lookup(context,arr) + end function pm_user_type_lookup_by_name !==================================================== ! Get type number of body of user type definition !==================================================== - function pm_user_typ_body(context,typ) result(tno) + function pm_user_type_body(context,typ) result(tno) type(pm_context),pointer:: context integer,intent(in):: typ integer:: tno type(pm_ptr):: v v=pm_dict_val(context,context%tcache,int(typ,pm_ln)) tno=v%offset - end function pm_user_typ_body + end function pm_user_type_body !============================================== ! Set the body of a user type declaration !============================================== - subroutine pm_user_typ_set_body(context,typ,tno) + subroutine pm_user_type_set_body(context,typ,tno) type(pm_context),pointer:: context integer,intent(in):: typ,tno - call pm_typ_set_val(context,typ,& + call pm_type_set_val(context,typ,& pm_fast_typeno(context,tno)) contains include 'ftypeno.inc' - end subroutine pm_user_typ_set_body + end subroutine pm_user_type_set_body !======================================================= ! If basic numeric type return name, else return -1 ! (mainly used for casting) !======================================================= - function pm_typ_numeric_name(context,typ) result(name) + function pm_type_numeric_name(context,typ) result(name) type(pm_context),pointer:: context integer,intent(in):: typ integer:: name,tno @@ -747,13 +739,13 @@ function pm_typ_numeric_name(context,typ) result(name) name=-1 return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_basic) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_basic) then name=pm_tv_name(tv) - elseif(pm_tv_kind(tv)==pm_typ_is_user) then - tno=pm_user_typ_body(context,typ) - tv=pm_typ_vect(context,tno) - if(pm_tv_kind(tv)==pm_typ_is_basic) then + elseif(pm_tv_kind(tv)==pm_type_is_user) then + tno=pm_user_type_body(context,typ) + tv=pm_type_vect(context,tno) + if(pm_tv_kind(tv)==pm_type_is_basic) then name=pm_tv_name(tv) else name=-1 @@ -762,44 +754,44 @@ function pm_typ_numeric_name(context,typ) result(name) name=-1 endif if(tno=pm_logical) name=-1 - end function pm_typ_numeric_name + end function pm_type_numeric_name !=============================================== ! Value associate with value or const type !=============================================== - function pm_typ_val(context,typ) result(v) + function pm_type_val(context,typ) result(v) type(pm_context),pointer:: context integer,intent(in):: typ type(pm_ptr):: v v=pm_dict_val(context,context%tcache,int(typ,pm_ln)) - end function pm_typ_val + end function pm_type_val !=============================================== ! Strip off non-storage elements of a type ! including one-element structs/recs !=============================================== - recursive function pm_typ_strip_to_basic(context,typ) result(typ2) + recursive function pm_type_strip_to_basic(context,typ) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ integer:: typ2 type(pm_ptr):: tv integer:: kind - tv=pm_typ_vect(context,typ) + tv=pm_type_vect(context,typ) kind=pm_tv_kind(tv) select case(kind) - case(pm_typ_is_all,pm_typ_is_vect,pm_typ_is_enveloped,pm_typ_is_param) - typ2=pm_typ_strip_to_basic(context,pm_tv_arg(tv,1)) - case(pm_typ_is_user) - typ2=pm_user_typ_body(context,typ) + case(pm_type_is_all,pm_type_is_vect,pm_type_is_enveloped,pm_type_is_param) + typ2=pm_type_strip_to_basic(context,pm_tv_arg(tv,1)) + case(pm_type_is_user) + typ2=pm_user_type_body(context,typ) case default typ2=typ end select - end function pm_typ_strip_to_basic + end function pm_type_strip_to_basic !============================================== ! Get mode from type (default private) !============================================== - function pm_typ_get_mode(context,typ) result(mode) + function pm_type_get_mode(context,typ) result(mode) type(pm_context),pointer:: context integer,intent(in):: typ integer:: mode @@ -809,18 +801,18 @@ function pm_typ_get_mode(context,typ) result(mode) mode=sym_mirrored return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then mode=iand(pm_tv_name(tv),mode_mask) else mode=sym_coherent endif - end function pm_typ_get_mode + end function pm_type_get_mode !========================================================================= ! Strip mode information, mode, from type typ yielding unmoded type typ2 !========================================================================= - function pm_typ_strip_mode(context,typ,mode) result(typ2) + function pm_type_strip_mode(context,typ,mode) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ integer,intent(out):: mode @@ -832,21 +824,21 @@ function pm_typ_strip_mode(context,typ,mode) result(typ2) mode=merge(sym_coherent,sym_mirrored,typ==0) return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then mode=iand(pm_tv_name(tv),mode_mask) typ2=pm_tv_arg(tv,1) else mode=sym_coherent typ2=typ endif - end function pm_typ_strip_mode + end function pm_type_strip_mode !========================================================================== ! Strip mode information, mode, from type typ yielding unmoded type typ2 ! Return in cond whether mode indicates a conditional context !========================================================================== - function pm_typ_strip_mode_and_cond(context,typ,mode,cond) result(typ2) + function pm_type_strip_mode_and_cond(context,typ,mode,cond) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ integer,intent(out):: mode @@ -860,8 +852,8 @@ function pm_typ_strip_mode_and_cond(context,typ,mode,cond) result(typ2) cond=.false. return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then mode=pm_tv_name(tv) typ2=pm_tv_arg(tv,1) cond=mode==sym_partial @@ -870,12 +862,12 @@ function pm_typ_strip_mode_and_cond(context,typ,mode,cond) result(typ2) typ2=typ cond=.false. endif - end function pm_typ_strip_mode_and_cond + end function pm_type_strip_mode_and_cond !============================================= ! Add mode information to an unmoded type !============================================= - function pm_typ_add_mode(context,typ,mode,iscond,istyp) result(typ2) + function pm_type_add_mode(context,typ,mode,iscond,istyp) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ,mode logical,intent(in):: iscond @@ -886,7 +878,7 @@ function pm_typ_add_mode(context,typ,mode,iscond,istyp) result(typ2) typ2=typ return endif - typ3=pm_typ_strip_mode(context,typ,mode2) + typ3=pm_type_strip_mode(context,typ,mode2) if(mode2/=sym_coherent) then write(*,*) trim(sym_names(mode2)) call pm_panic('add-mode to moded type') @@ -894,18 +886,18 @@ function pm_typ_add_mode(context,typ,mode,iscond,istyp) result(typ2) if(mode==sym_coherent.and..not.(iscond.or.present(istyp))) then typ2=typ else - array(1)=pm_typ_new_par_kind + array(1)=pm_type_new_par_kind array(2)=merge(sym_partial,mode,iscond) array(3)=typ - typ2=pm_new_typ(context,array) + typ2=pm_new_type(context,array) endif - end function pm_typ_add_mode + end function pm_type_add_mode !======================================================== ! Replace mode information in a (possibly) moded type !======================================================== - function pm_typ_replace_mode(context,typ1,mode,iscond) result(typ2) + function pm_type_replace_mode(context,typ1,mode,iscond) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ1,mode logical,intent(in):: iscond @@ -917,8 +909,8 @@ function pm_typ_replace_mode(context,typ1,mode,iscond) result(typ2) typ2=typ1 return endif - tv=pm_typ_vect(context,typ1) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ1) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then typ=pm_tv_arg(tv,1) else typ=typ1 @@ -926,12 +918,12 @@ function pm_typ_replace_mode(context,typ1,mode,iscond) result(typ2) if(mode==sym_coherent.and..not.iscond) then typ2=typ else - array(1)=pm_typ_new_par_kind + array(1)=pm_type_new_par_kind array(2)=merge(sym_partial,mode,iscond) array(3)=typ - typ2=pm_new_typ(context,array) + typ2=pm_new_type(context,array) endif - end function pm_typ_replace_mode + end function pm_type_replace_mode !============================================================================================= @@ -945,7 +937,7 @@ end function pm_typ_replace_mode ! shared_ok -- permissible to have an argumnet with 'shared' mode ! complete -- cannot have an argument mode associated with a conditional context !============================================================================================ - function pm_typ_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& + function pm_type_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& result(combined_mode) type(pm_context),pointer:: context integer,intent(in),dimension(:):: array @@ -959,7 +951,7 @@ function pm_typ_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& !cmode=merge(sym_shared,sym_mirrored,shared_ok) cmode=sym_mirrored do i=1,size(array) - tno=pm_typ_strip_mode(context,array(i),mode) + tno=pm_type_strip_mode(context,array(i),mode) if(complete) then if(mode==sym_partial) then combined_mode=-i-1000 @@ -970,7 +962,7 @@ function pm_typ_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& endif endif if(mode==sym_shared.and..not.shared_ok) then - if(iand(pm_typ_flags(context,tno),pm_typ_has_distributed)/=0) then + if(iand(pm_type_flags(context,tno),pm_type_has_distributed)/=0) then combined_mode=-i return endif @@ -979,7 +971,7 @@ function pm_typ_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& enddo if(cmode==sym_chan) cmode=sym_coherent combined_mode=cmode - end function pm_typ_combine_modes + end function pm_type_combine_modes !=================================== ! Does mode1 include mode2 ? @@ -1024,7 +1016,7 @@ end function pm_mode_compatable ! -2 if conversion not possible ! in a conditional context !=================================================== - function pm_typ_convert_mode(mode1,mode2,iscond) result(mode3) + function pm_type_convert_mode(mode1,mode2,iscond) result(mode3) integer,intent(in):: mode1,mode2 logical,intent(in):: iscond integer:: mode3 @@ -1055,28 +1047,28 @@ function pm_typ_convert_mode(mode1,mode2,iscond) result(mode3) if(mode1/=mode2.and.iscond) mode3=-2 end select endif - end function pm_typ_convert_mode + end function pm_type_convert_mode !========================================================== ! Remove both mode information and internal vector type !========================================================== - function pm_typ_strip_mode_and_vect(context,tno) result(tno2) + function pm_type_strip_mode_and_vect(context,tno) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno integer:: tno2 type(pm_ptr):: tv integer:: mode - tno2=pm_typ_strip_mode(context,tno,mode) - tv=pm_typ_vect(context,tno2) - if(pm_tv_kind(tv)==pm_typ_is_vect) then - tno2=pm_typ_strip_mode(context,pm_tv_arg(tv,1),mode) + tno2=pm_type_strip_mode(context,tno,mode) + tv=pm_type_vect(context,tno2) + if(pm_tv_kind(tv)==pm_type_is_vect) then + tno2=pm_type_strip_mode(context,pm_tv_arg(tv,1),mode) endif - end function pm_typ_strip_mode_and_vect + end function pm_type_strip_mode_and_vect !============================================================================= ! Check if two concrete types equal (ignoring modes and vector type wrappers) !============================================================================= - function pm_typ_equal(context,tno1,tno2) result(ok) + function pm_type_equal(context,tno1,tno2) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno1,tno2 logical:: ok @@ -1085,87 +1077,87 @@ function pm_typ_equal(context,tno1,tno2) result(ok) if(tno1==tno2) then ok=.true. else - tv1=pm_typ_vect(context,tno1) - tv2=pm_typ_vect(context,tno2) + tv1=pm_type_vect(context,tno1) + tv2=pm_type_vect(context,tno2) tk1=pm_tv_kind(tv1) tk2=pm_tv_kind(tv2) typ1=tno1 typ2=tno2 - if(tk1==pm_typ_is_par_kind.or.tk1==pm_typ_is_vect) then + if(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) then typ1=pm_tv_arg(tv1,1) endif - if(tk2==pm_typ_is_par_kind.or.tk2==pm_typ_is_vect) then + if(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) then typ2=pm_tv_arg(tv2,1) endif ok=typ1==typ2 if(.not.ok) then - tv1=pm_typ_vect(context,typ1) - tv2=pm_typ_vect(context,typ2) + tv1=pm_type_vect(context,typ1) + tv2=pm_type_vect(context,typ2) tk1=pm_tv_kind(tv1) tk2=pm_tv_kind(tv2) - if(tk1==pm_typ_is_par_kind.or.tk1==pm_typ_is_vect) then + if(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) then typ1=pm_tv_arg(tv1,1) endif - if(tk2==pm_typ_is_par_kind.or.tk2==pm_typ_is_vect) then + if(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) then typ2=pm_tv_arg(tv2,1) endif ok=typ1==typ2 endif endif - end function pm_typ_equal + end function pm_type_equal !=================================================================== ! Given a struct/rec template and type, return type parameters !================================================================== - function pm_typ_extract_params(context,templ,typ,params) result(ok) + function pm_type_extract_params(context,templ,typ,params) result(ok) type(pm_context),pointer:: context integer,intent(in):: templ,typ integer,intent(inout),dimension(:):: params - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo logical:: ok integer:: ubase integer,dimension(max_user_nesting):: user ubase=1 - ok=pm_test_typ_includes(context,templ,typ,& - pm_typ_incl_val+pm_typ_incl_extract,einfo,params,1,user,ubase) - end function pm_typ_extract_params + ok=pm_test_type_includes(context,templ,typ,& + pm_type_incl_val+pm_type_incl_extract,einfo,params,1,user,ubase) + end function pm_type_extract_params !====================================== ! Does supertype include subtype? !====================================== - function pm_typ_includes(context,supertype,subtype,& + function pm_type_includes(context,supertype,subtype,& mode,einfo) result(ok) type(pm_context),pointer:: context integer,intent(in):: supertype,subtype integer,intent(in):: mode - type(pm_typ_einfo),intent(out):: einfo + type(pm_type_einfo),intent(out):: einfo logical:: ok integer:: ubase integer,dimension(max_user_nesting):: user,params - if(pm_typ_extra_debug) then - write(*,*) 'CHECK',trim(pm_typ_as_string(context,supertype)),'>>',& - trim(pm_typ_as_string(context,subtype)) + if(pm_type_extra_debug) then + write(*,*) 'CHECK',trim(pm_type_as_string(context,supertype)),'>>',& + trim(pm_type_as_string(context,subtype)) endif ubase=1 ! This deals with rare problem of *(..T..) where T is struct/rec parameter - if(iand(mode,pm_typ_incl_indirect)/=0) then - if(iand(pm_typ_flags(context,supertype),pm_typ_has_params)/=0) then + if(iand(mode,pm_type_incl_indirect)/=0) then + if(iand(pm_type_flags(context,supertype),pm_type_has_params)/=0) then params=-1 endif endif - einfo%kind=pm_typ_err_none + einfo%kind=pm_type_err_none einfo%typ1=supertype einfo%typ2=subtype - ok=pm_test_typ_includes(context,supertype,subtype,& + ok=pm_test_type_includes(context,supertype,subtype,& mode,einfo,params,1,user,ubase) - if(pm_typ_extra_debug) then - write(*,*) 'CHECKED ',ok,trim(pm_typ_as_string(context,supertype)),'>>',& - trim(pm_typ_as_string(context,subtype)) + if(pm_type_extra_debug) then + write(*,*) 'CHECKED ',ok,trim(pm_type_as_string(context,supertype)),'>>',& + trim(pm_type_as_string(context,subtype)) endif - end function pm_typ_includes + end function pm_type_includes !====================================================== ! Does supertype include subtype? @@ -1175,13 +1167,13 @@ end function pm_typ_includes ! user(ubase:) maintains a stack of active user types to ! prevent runaway recursion !====================================================== - recursive function pm_test_typ_includes(context,supertype,subtype,& + recursive function pm_test_type_includes(context,supertype,subtype,& mode,einfo,params,base,user,ubase)& result(ok) type(pm_context),pointer:: context integer,intent(in):: supertype,subtype integer,intent(in):: mode - type(pm_typ_einfo),intent(out):: einfo + type(pm_type_einfo),intent(out):: einfo integer,dimension(:),intent(inout):: params integer,intent(in):: base integer,dimension(:),intent(inout):: user @@ -1192,11 +1184,11 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& integer:: i,j,tk,uk,nt,nu logical:: has_d - if(pm_typ_extra_debug) then + if(pm_type_extra_debug) then write(*,*) '==================' write(*,*) 'Test incl',supertype,subtype - write(*,*) trim(pm_typ_as_string(context,supertype)),' ',& - trim(pm_typ_as_string(context,subtype)) + write(*,*) trim(pm_type_as_string(context,supertype)),' ',& + trim(pm_type_as_string(context,subtype)) write(*,*) 'base=',base write(*,*) '==================' endif @@ -1209,15 +1201,15 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& if(p==0) then ok=.true. else - t=pm_typ_vect(context,p) + t=pm_type_vect(context,p) tk=pm_tv_kind(t) - if(tk==pm_typ_is_user) then + if(tk==pm_type_is_user) then r=pm_dict_val(context,context%tcache,int(p,pm_ln)) - ok=pm_test_typ_includes(context,int(r%offset),q,& + ok=pm_test_type_includes(context,int(r%offset),q,& mode,einfo,params,base,user,ubase) - elseif(tk==pm_typ_is_any) then + elseif(tk==pm_type_is_any) then do i=1,pm_tv_numargs(t) - if(pm_test_typ_includes(context,pm_tv_arg(t,i),q,& + if(pm_test_type_includes(context,pm_tv_arg(t,i),q,& mode,einfo,params,base,user,ubase)) then ok=.true. return @@ -1237,27 +1229,27 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& return endif - t=pm_typ_vect(context,p) - u=pm_typ_vect(context,q) + t=pm_type_vect(context,p) + u=pm_type_vect(context,q) uk=pm_tv_kind(u) tk=pm_tv_kind(t) - if(tk==pm_typ_is_includes) then - if(uk==pm_typ_is_includes) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + if(tk==pm_type_is_includes) then + if(uk==pm_type_is_includes) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) if(ok) then - ok=ok.and.pm_test_typ_includes(context,& + ok=ok.and.pm_test_type_includes(context,& pm_tv_arg(u,2),pm_tv_arg(t,2),& - pm_typ_incl_equiv,einfo,params,base,user,ubase) + pm_type_incl_equiv,einfo,params,base,user,ubase) endif else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) if(ok) then - ok=ok.and.pm_test_typ_includes(context,& + ok=ok.and.pm_test_type_includes(context,& q,pm_tv_arg(t,2),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) endif endif return @@ -1266,36 +1258,36 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& ! Cases where the second type needs to be checked first select case(uk) - case(pm_typ_is_proc) + case(pm_type_is_proc) if(p==pm_proc) then ok=.true. return endif - case(pm_typ_is_single_name) + case(pm_type_is_single_name) if(p==pm_name) then ok=.true. return endif - case(pm_typ_is_value) + case(pm_type_is_value) select case(tk) - case(pm_typ_is_const) - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + case(pm_type_is_const) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& params,base,user,ubase) return - case(pm_typ_is_value) + case(pm_type_is_value) ok=pm_tv_name(t)==pm_tv_name(u) return - case(pm_typ_is_basic) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),mode,einfo,& + case(pm_type_is_basic) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,einfo,& params,base,user,ubase) return end select - case(pm_typ_is_const) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),mode,einfo,& + case(pm_type_is_const) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,einfo,& params,base,user,ubase) return - case(pm_typ_is_user) - if(tk/=pm_typ_is_user) then + case(pm_type_is_user) + if(tk/=pm_type_is_user) then do i=2,ubase,2 if(user(i)==p.and.user(i+1)==q) then ok=.true. @@ -1308,23 +1300,23 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& user(ubase+1)=p user(ubase+2)=q r=pm_dict_val(context,context%tcache,int(q,pm_ln)) - ok=pm_test_typ_includes(context,p,int(r%offset),& + ok=pm_test_type_includes(context,p,int(r%offset),& mode,einfo,params,base,user,ubase+2) return endif - case(pm_typ_is_any) + case(pm_type_is_any) do i=1,pm_tv_numargs(u) - if(.not.pm_test_typ_includes(context,p,pm_tv_arg(u,i),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase)) then + if(.not.pm_test_type_includes(context,p,pm_tv_arg(u,i),& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase)) then ok=.false. return endif enddo ok=.true. return - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(u) - if(pm_test_typ_includes(context,p,pm_tv_arg(u,i),& + if(pm_test_type_includes(context,p,pm_tv_arg(u,i),& mode,einfo,params,base,user,ubase)) then ok=.true. return @@ -1332,38 +1324,38 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& enddo ok=.false. return - case(pm_typ_is_except) - if(tk==pm_typ_is_except) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + case(pm_type_is_except) + if(tk==pm_type_is_except) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase).and.& - pm_test_typ_includes(context,pm_tv_arg(u,2),pm_tv_arg(t,2),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + pm_test_type_includes(context,pm_tv_arg(u,2),pm_tv_arg(t,2),& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) return else - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) return endif - case(pm_typ_is_includes) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& + case(pm_type_is_includes) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) return - case(pm_typ_is_undef_result) + case(pm_type_is_undef_result) ok=.false. return - case(pm_typ_is_par_kind) + case(pm_type_is_par_kind) nu=pm_tv_name(u) - if(tk==pm_typ_is_par_kind) then + if(tk==pm_type_is_par_kind) then nt=pm_tv_name(t) - if(iand(mode,pm_typ_incl_val)/=0) then + if(iand(mode,pm_type_incl_val)/=0) then ok=pm_mode_includes(nt,nu) if(ok) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) endif else if(nt==nu) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) else ok=pm_mode_includes(nt,nu) @@ -1371,29 +1363,29 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& endif return else - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) return endif - case(pm_typ_is_param) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& + case(pm_type_is_param) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) return -!!$ case(pm_typ_is_vect) -!!$ if(iand(pm_typ_flags(context,p),pm_typ_has_vect)==0) then -!!$ ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& +!!$ case(pm_type_is_vect) +!!$ if(iand(pm_type_flags(context,p),pm_type_has_vect)==0) then +!!$ ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& !!$ mode,einfo,params,base,user,ubase) !!$ return !!$ endif - case(pm_typ_is_bottom) + case(pm_type_is_bottom) ok=.true. return end select select case(tk) - case(pm_typ_is_basic) + case(pm_type_is_basic) ok=.false. - case(pm_typ_is_dref) + case(pm_type_is_dref) if(tk/=uk) then ok=.false. return @@ -1401,7 +1393,7 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& nt=pm_tv_name(t) nu=pm_tv_name(u) if(nt==pm_dref_is_any) then - if(nu/=pm_dref_is_any.and.iand(mode,pm_typ_incl_typ)/=0) then + if(nu/=pm_dref_is_any.and.iand(mode,pm_type_incl_type)/=0) then ok=.true. return endif @@ -1414,14 +1406,14 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& return endif do i=1,pm_tv_numargs(t) - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,i),& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then ok=.false. return endif enddo ok=.true. - case(pm_typ_is_struct,pm_typ_is_rec) + case(pm_type_is_struct,pm_type_is_rec) if(tk/=uk) then ok=.false. return @@ -1431,10 +1423,10 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& return endif do i=1,pm_tv_numargs(t) - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,i),& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then ok=.false. - einfo%kind=ior(einfo%kind,pm_typ_err_elem) + einfo%kind=ior(einfo%kind,pm_type_err_elem) einfo%name=pm_tv_name(t) einfo%index=i einfo%typ1=pm_tv_arg(t,i) @@ -1443,41 +1435,41 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& endif enddo ok=.true. - case(pm_typ_is_array) - if(uk/=pm_typ_is_array) then + case(pm_type_is_array) + if(uk/=pm_type_is_array) then ok=.false. else if(.not.(pm_tv_name(t)==pm_tv_name(u).or.pm_tv_name(t)==0)) then ok=.false. else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase).and.& - pm_test_typ_includes(context,pm_tv_arg(t,2),pm_tv_arg(u,2),& + pm_test_type_includes(context,pm_tv_arg(t,2),pm_tv_arg(u,2),& mode,einfo,params,base,user,ubase) endif endif - case(pm_typ_is_type,pm_typ_is_poly) + case(pm_type_is_type,pm_type_is_poly) if(uk/=tk) then ok=.false. else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) endif - case(pm_typ_is_tuple,pm_typ_is_vtuple) - if(uk/=pm_typ_is_tuple.and.uk/=pm_typ_is_vtuple) then + case(pm_type_is_tuple,pm_type_is_vtuple) + if(uk/=pm_type_is_tuple.and.uk/=pm_type_is_vtuple) then ok=.false. - elseif(tk==pm_typ_is_tuple.and.uk==pm_typ_is_vtuple) then + elseif(tk==pm_type_is_tuple.and.uk==pm_type_is_vtuple) then ok=.false. elseif(pm_tv_name(t)/=pm_tv_name(u)) then ok=.false. else nt=pm_tv_numargs(t) nu=pm_tv_numargs(u) - if(nt>nu.and.uk/=pm_typ_is_vtuple) then + if(nt>nu.and.uk/=pm_type_is_vtuple) then ok=.false. return endif - if(nu>nt.and.tk/=pm_typ_is_vtuple) then + if(nu>nt.and.tk/=pm_type_is_vtuple) then ok=.false. return endif @@ -1496,7 +1488,7 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& endif endif do i=j,min(nt,nu) - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,i),& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then ok=.false. return @@ -1504,7 +1496,7 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& enddo if(nu>nt) then do i=nt+1,nu - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,nt),& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,nt),& pm_tv_arg(u,i),mode,einfo,params,base,& user,ubase)) then ok=.false. @@ -1513,7 +1505,7 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& enddo else do i=nu+1,nt - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,nt),& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,nt),& pm_tv_arg(u,i),mode,einfo,params,base,& user,ubase)) then ok=.false. @@ -1523,15 +1515,15 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& endif ok=.true. endif - case(pm_typ_is_user) - if(uk==pm_typ_is_user) then + case(pm_type_is_user) + if(uk==pm_type_is_user) then ! Check P(p1,p2) < Q(q1,q2) <=> p11) then ok=.false. else - ok=pm_test_typ_includes(context,& + ok=pm_test_type_includes(context,& pm_tv_arg(t,1),pm_tv_arg(u,1),& - pm_typ_incl_typ+pm_typ_incl_nomatch,& + pm_type_incl_type+pm_type_incl_nomatch,& einfo,params,base,user,ubase) endif - case(pm_typ_is_proc_sig) - if(uk/=pm_typ_is_proc_sig) then + case(pm_type_is_proc_sig) + if(uk/=pm_type_is_proc_sig) then ok=.false. return endif @@ -1608,45 +1600,41 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& ok=.false. return endif - ok=pm_test_typ_includes(context,& + ok=pm_test_type_includes(context,& pm_tv_arg(u,1),pm_tv_arg(t,1),& - pm_typ_incl_typ+pm_typ_incl_nomatch,& + pm_type_incl_type+pm_type_incl_nomatch,& einfo,params,base,user,ubase).and.& - pm_test_typ_includes(context,& + pm_test_type_includes(context,& pm_tv_arg(t,2),pm_tv_arg(u,2),& - pm_typ_incl_typ+pm_typ_incl_nomatch,& + pm_type_incl_type+pm_type_incl_nomatch,& einfo,params,base,user,ubase) - case(pm_typ_is_par_kind) + case(pm_type_is_par_kind) ! Most cases catered for by uk switch - remaining case - ok=iand(mode,pm_typ_incl_val)/=0.and.& + ok=iand(mode,pm_type_incl_val)/=0.and.& pm_mode_includes(pm_tv_name(t),sym_coherent).and.& - pm_test_typ_includes(context,pm_tv_arg(t,1),q,& + pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base,user,ubase) - case(pm_typ_is_undef_result) + case(pm_type_is_undef_result) ok=.false. - case(pm_typ_is_contains) - if(uk==pm_typ_is_contains) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + case(pm_type_is_contains) + if(uk==pm_type_is_contains) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) else - ok=pm_typ_contains_elem(context,pm_tv_arg(t,1),q,& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_type_contains_elem(context,pm_tv_arg(t,1),q,& + ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) endif - case(pm_typ_is_has) - if(uk==pm_typ_is_has) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + case(pm_type_is_has) + if(uk==pm_type_is_has) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) else i=ubase+1 - r=pm_typ_vect(context,pm_tv_arg(t,1)) - if(pm_tv_kind(r)==pm_typ_is_interface) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - if(ok) return - elseif(pm_tv_kind(r)==pm_typ_is_proc.and.& - pm_tv_kind(u)==pm_typ_is_proc) then + r=pm_type_vect(context,pm_tv_arg(t,1)) + if(pm_tv_kind(r)==pm_type_is_proc.and.& + pm_tv_kind(u)==pm_type_is_proc) then do i=1,pm_tv_numargs(u) - if(pm_proc_typ_conforms(context,pm_tv_arg(t,1),& + if(pm_proc_type_conforms(context,pm_tv_arg(t,1),& pm_tv_arg(u,i))) then ok=.true. return @@ -1659,64 +1647,64 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& if(ok) then ! This test does parameter checking in correct context ! (indirect_include checks in isolated context) - ok=pm_test_typ_includes(context,& + ok=pm_test_type_includes(context,& pm_tv_arg(t,1),j,& mode,einfo,params,base,user,ubase) endif endif - case(pm_typ_is_value) - if(uk/=pm_typ_is_value) then + case(pm_type_is_value) + if(uk/=pm_type_is_value) then ok=.false. else ok=pm_tv_name(t)==pm_tv_name(u) endif - case(pm_typ_is_const) - if(uk/=pm_typ_is_const.and.uk/=pm_typ_is_value) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& + case(pm_type_is_const) + if(uk/=pm_type_is_const.and.uk/=pm_type_is_value) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base,user,ubase) - if(iand(pm_typ_flags(context,q),pm_typ_has_storage)/=0) ok=.false. + if(iand(pm_type_flags(context,q),pm_type_has_storage)/=0) ok=.false. else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) endif - case(pm_typ_is_interface,pm_typ_is_enveloped) - if(uk==pm_typ_is_interface.or.uk==pm_typ_is_enveloped) then + case(pm_type_is_enveloped) + if(uk==pm_type_is_enveloped) then ok=pm_tv_name(t)==pm_tv_name(u) else ok=.false. endif - case(pm_typ_is_except) - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& + case(pm_type_is_except) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base,user,ubase) if(ok) then - ok=.not.pm_test_typ_includes(context,pm_tv_arg(t,2),q,& + ok=.not.pm_test_type_includes(context,pm_tv_arg(t,2),q,& mode,einfo,params,base,user,ubase) endif - case(pm_typ_is_params) + case(pm_type_is_params) nt=pm_tv_name(t) if(base+nt>size(params)) then call pm_panic('Program too complex - Excessive type nesting') endif params(base:base+nt)=-1 - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base+nt,user,ubase) - case(pm_typ_is_param) - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& + case(pm_type_is_param) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base,user,ubase) - if(ok.and.iand(mode,pm_typ_incl_extract)/=0) then - if(iand(mode,pm_typ_incl_nomatch)/=0) return + if(ok.and.iand(mode,pm_type_incl_extract)/=0) then + if(iand(mode,pm_type_incl_nomatch)/=0) return nt=pm_tv_name(t) if(params(nt)==-1) then params(nt)=q else - params(nt)=pm_typ_combine(context,params(nt),q) + params(nt)=pm_type_combine(context,params(nt),q) endif endif - case(pm_typ_is_amp,pm_typ_is_vect) + case(pm_type_is_amp,pm_type_is_vect) ok=tk==uk - if(ok) ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + if(ok) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) - case(pm_typ_is_bottom) + case(pm_type_is_bottom) ok=.false. case default write(*,*) 'Type=',p @@ -1725,7 +1713,7 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& do i=1,pm_tv_numargs(t) write(*,*) 'Arg=',pm_tv_arg(t,i) enddo - call pm_panic('pm_test_typ_includes bad type kind') + call pm_panic('pm_test_type_includes bad type kind') end select contains @@ -1734,22 +1722,22 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& include 'fisnull.inc' include 'ftypeno.inc' - end function pm_test_typ_includes + end function pm_test_type_includes ! Does type correspond to only one concrete type - recursive function pm_typ_is_concrete(context,tno) result(ok) + recursive function pm_type_is_concrete(context,tno) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno logical:: ok - ok=iand(pm_typ_flags(context,tno),pm_typ_has_generic)==0 + ok=iand(pm_type_flags(context,tno),pm_type_has_generic)==0 contains include 'fisnull.inc' - end function pm_typ_is_concrete + end function pm_type_is_concrete ! Does a type directly include itself (not as element of ! embedded struct/rec or array) - recursive function pm_typ_is_recur(context,rno,tno) result(ok) + recursive function pm_type_is_recur(context,rno,tno) result(ok) type(pm_context),pointer:: context integer,intent(in):: rno,tno logical:: ok @@ -1758,31 +1746,31 @@ recursive function pm_typ_is_recur(context,rno,tno) result(ok) integer:: j ok=.false. if(tno==0) return - tv=pm_typ_vect(context,tno) - if(pm_tv_kind(tv)==pm_typ_is_any.or.& - pm_tv_kind(tv)==pm_typ_is_all) then + tv=pm_type_vect(context,tno) + if(pm_tv_kind(tv)==pm_type_is_any.or.& + pm_tv_kind(tv)==pm_type_is_all) then do j=1,pm_tv_numargs(tv) tno2=pm_tv_arg(tv,j) if(tno2==rno) then ok=.true. return - elseif(pm_typ_is_recur(context,rno,tno2)) then + elseif(pm_type_is_recur(context,rno,tno2)) then ok=.true. return endif enddo endif - end function pm_typ_is_recur + end function pm_type_is_recur ! Does a type contain an element (structure/rec component, ! array domain or values, applied recursively) of a given ! type? - recursive function pm_typ_contains_elem(context,p,q,& + recursive function pm_type_contains_elem(context,p,q,& mode,einfo,params,base,user,ubase) result(ok) type(pm_context),pointer:: context integer,intent(in):: p,q integer,intent(in):: mode - type(pm_typ_einfo),intent(out):: einfo + type(pm_type_einfo),intent(out):: einfo integer,dimension(:),intent(inout):: params integer,intent(in):: base integer,dimension(:),intent(inout):: user @@ -1790,7 +1778,7 @@ recursive function pm_typ_contains_elem(context,p,q,& type(pm_ptr):: u logical:: ok integer:: i,k,uk - if(pm_test_typ_includes(context,p,q,mode,einfo,& + if(pm_test_type_includes(context,p,q,mode,einfo,& params,base,user,ubase)) then ok=.true. return @@ -1799,89 +1787,89 @@ recursive function pm_typ_contains_elem(context,p,q,& ok=.false. return endif - u=pm_typ_vect(context,q) + u=pm_type_vect(context,q) uk=pm_tv_kind(u) select case(uk) - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(u) - if(pm_typ_contains_elem(context,p,pm_tv_arg(u,i),& + if(pm_type_contains_elem(context,p,pm_tv_arg(u,i),& mode,einfo,params,base,user,ubase)) then ok=.true. return endif enddo ok=.false. - case(pm_typ_is_any) + case(pm_type_is_any) do i=1,pm_tv_numargs(u) - if(.not.pm_typ_contains_elem(context,p,pm_tv_arg(u,i),& + if(.not.pm_type_contains_elem(context,p,pm_tv_arg(u,i),& mode,einfo,params,base,user,ubase)) then ok=.false. return endif enddo ok=.true. - case(pm_typ_is_except) - ok=pm_typ_contains_elem(context,p,pm_tv_arg(u,1),& + case(pm_type_is_except) + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) if(ok) then - ok=.not.pm_typ_includes(context,pm_tv_arg(u,2),& - p,pm_typ_incl_typ,einfo) + ok=.not.pm_type_includes(context,pm_tv_arg(u,2),& + p,pm_type_incl_type,einfo) endif - case(pm_typ_is_array) - if(pm_typ_contains_elem(context,p,pm_tv_arg(u,1),& + case(pm_type_is_array) + if(pm_type_contains_elem(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase)) then ok=.true. return - elseif(pm_typ_contains_elem(context,p,pm_tv_arg(u,2),& + elseif(pm_type_contains_elem(context,p,pm_tv_arg(u,2),& mode,einfo,params,base,user,ubase)) then ok=.true. return else ok=.false. endif - case(pm_typ_is_struct,pm_typ_is_rec,& - pm_typ_is_tuple,pm_typ_is_vtuple) + case(pm_type_is_struct,pm_type_is_rec,& + pm_type_is_tuple,pm_type_is_vtuple) do i=1,pm_tv_numargs(u) - if(pm_typ_contains_elem(context,p,pm_tv_arg(u,i),& + if(pm_type_contains_elem(context,p,pm_tv_arg(u,i),& mode,einfo,params,base,user,ubase)) then ok=.true. return endif enddo ok=.false. - case(pm_typ_is_dref) - ok=pm_typ_contains_elem(context,p,pm_tv_arg(u,3),& + case(pm_type_is_dref) + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,3),& mode,einfo,params,base,user,ubase) if(.not.ok) then i=pm_tv_arg(u,2) - k=pm_typ_kind(context,i) - if(k==pm_typ_is_par_kind) then - u=pm_typ_vect(context,i) + k=pm_type_kind(context,i) + if(k==pm_type_is_par_kind) then + u=pm_type_vect(context,i) i=pm_tv_arg(u,1) - k=pm_typ_kind(context,i) + k=pm_type_kind(context,i) endif - if(k==pm_typ_is_dref) then - ok=pm_typ_contains_elem(context,p,i,& + if(k==pm_type_is_dref) then + ok=pm_type_contains_elem(context,p,i,& mode,einfo,params,base,user,ubase) endif endif - case(pm_typ_is_par_kind,pm_typ_is_vect,& - pm_typ_is_enveloped,pm_typ_is_interface,& - pm_typ_is_contains,pm_typ_is_has,& - pm_typ_is_params,pm_typ_is_param) - ok=pm_typ_contains_elem(context,p,pm_tv_arg(u,1),& + case(pm_type_is_par_kind,pm_type_is_vect,& + pm_type_is_enveloped,& + pm_type_is_contains,pm_type_is_has,& + pm_type_is_params,pm_type_is_param) + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) case default ok=.false. end select - end function pm_typ_contains_elem + end function pm_type_contains_elem !=============================================== ! Perform enveloping conversions if possible ! Returns -1 if not possible !============================================== - function pm_typ_convert(context,partyp,argtyp,dopoly) result(ctyp) + function pm_type_convert(context,partyp,argtyp,dopoly) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp logical,intent(in):: dopoly @@ -1893,254 +1881,89 @@ function pm_typ_convert(context,partyp,argtyp,dopoly) result(ctyp) if(partyp<=0.or.argtyp<=0) then return endif - tk=pm_typ_kind(context,ptyp) - do while(tk==pm_typ_is_user) - ptyp=pm_user_typ_body(context,ptyp) - tk=pm_typ_kind(context,ptyp) + tk=pm_type_kind(context,ptyp) + do while(tk==pm_type_is_user) + ptyp=pm_user_type_body(context,ptyp) + tk=pm_type_kind(context,ptyp) enddo - if(tk==pm_typ_is_interface) then - ctyp=pm_interface_typ_convert(context,ptyp,argtyp) - endif - if(ctyp<0.and.tk==pm_typ_is_proc) then - ctyp=pm_proc_typ_convert(context,ptyp,argtyp) + if(ctyp<0.and.tk==pm_type_is_proc) then + ctyp=pm_proc_type_convert(context,ptyp,argtyp) endif - if(ctyp<0.and.dopoly.and.tk==pm_typ_is_poly) then - ctyp=pm_poly_typ_convert(context,ptyp,argtyp) + if(ctyp<0.and.dopoly.and.tk==pm_type_is_poly) then + ctyp=pm_poly_type_convert(context,ptyp,argtyp) endif - end function pm_typ_convert + end function pm_type_convert !================================================================ ! Autoconversion to broader poly type ! Returns -1 if not possible !================================================================ - function pm_poly_typ_convert(context,partyp,argtyp) result(ctyp) + function pm_poly_type_convert(context,partyp,argtyp) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp integer:: ctyp type(pm_ptr):: tv1,tv2 - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo ctyp=-1 - tv1=pm_typ_vect(context,partyp) - tv2=pm_typ_vect(context,argtyp) - if(pm_tv_kind(tv1)==pm_typ_is_poly.and.pm_tv_kind(tv2)==pm_typ_is_poly) then - if(pm_typ_includes(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_typ_incl_typ,einfo)) then + tv1=pm_type_vect(context,partyp) + tv2=pm_type_vect(context,argtyp) + if(pm_tv_kind(tv1)==pm_type_is_poly.and.pm_tv_kind(tv2)==pm_type_is_poly) then + if(pm_type_includes(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + pm_type_incl_type,einfo)) then ctyp=partyp endif endif - end function pm_poly_typ_convert + end function pm_poly_type_convert - !================================================================ - ! Autoconversion to interface type, yielding enveloped type - ! Returns -1 if not possible - !================================================================ - function pm_interface_typ_convert(context,partyp,argtyp) result(ctyp) - type(pm_context),pointer:: context - integer,intent(in):: partyp,argtyp - integer:: ctyp - integer,dimension(4):: args - integer:: tno - type(pm_ptr):: tv - tv=pm_typ_vect(context,partyp) - tno=partyp - if(pm_tv_kind(tv)==pm_typ_is_user) then - tno=pm_user_typ_body(context,partyp) - tv=pm_typ_vect(context,tno) - endif - if(pm_tv_kind(tv)==pm_typ_is_interface) then - args(1)=pm_typ_new_enveloped - args(2)=pm_tv_name(tv) - args(3)=argtyp - args(4)=tno - ctyp=pm_new_typ(context,args) - else - ctyp=-1 - endif - end function pm_interface_typ_convert - - !=============================================================== - ! Check if type q conforms to interface p - ! - if q is also an interface then add information that q:p - !=============================================================== - recursive function pm_interface_typ_conforms(context,p,q,einfo,except) result(ok) - type(pm_context),pointer:: context - integer,intent(in):: p,q - type(pm_typ_einfo),intent(out):: einfo - integer,intent(in),optional:: except - logical:: ok - integer:: s,tk,uk,i,j,k,nt,nu,elem,err,name - type(pm_ptr):: t,u,r,names1,names2 - integer,dimension(max_user_nesting):: params - logical:: ok2 - t=pm_typ_vect(context,p) - u=pm_typ_vect(context,q) - tk=pm_tv_kind(t) - uk=pm_tv_kind(u) - select case(uk) - case(pm_typ_is_user) - r=pm_dict_val(context,context%tcache,int(q,pm_ln)) - ok=pm_interface_typ_conforms(context,p,int(r%offset),& - einfo,except) - case(pm_typ_is_any) - do i=1,pm_tv_numargs(u) - if(present(except)) then - if(pm_typ_includes(context,except,pm_tv_arg(u,i),& - pm_typ_incl_typ,einfo)) cycle - endif - if(.not.pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,except)) then - ok=.false. - endif - enddo - ok=.true. - case(pm_typ_is_all) - do i=1,pm_tv_numargs(u) - if(pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,except)) then - ok=.true. - endif - enddo - ok=.false. - case(pm_typ_is_except) - if(present(except)) then - ok=pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,pm_typ_combine(context,pm_tv_arg(u,2),except)) - else - ok=pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,pm_tv_arg(u,2)) - endif - case(pm_typ_is_param,pm_typ_is_params,& - pm_typ_is_enveloped,pm_typ_is_contains,pm_typ_is_has,& - pm_typ_is_vect) - ok=pm_interface_typ_conforms(context,p,pm_tv_arg(u,1),& - einfo,except) - case(pm_typ_is_interface) - names1=pm_name_val(context,pm_tv_name(t)) - names2=pm_name_val(context,pm_tv_name(u)) - - ! Check consistency with any shadowing elements - outer: do i=1,pm_fast_esize(names1) - nt=names1%data%i(names1%offset+i) - do j=1,pm_fast_esize(names2) - nu=names2%data%i(names2%offset+j) - if(nt==nu.or.(nt==-nu.and.nt>0)) then - if(pm_typ_includes(context,& - pm_tv_arg(t,i+1),pm_tv_arg(u,j+1),& - pm_typ_incl_typ,einfo)) then - cycle outer - else - einfo%kind=pm_typ_err_interface_nesting - einfo%typ1=p - einfo%typ2=q - einfo%vtyp1=pm_tv_arg(t,i+1) - einfo%vtyp2=pm_tv_arg(u,j+1) - einfo%vname=abs(nt) - ok=.false. - return - endif - elseif(nt==-nu.and.nt<0) then - einfo%kind=pm_typ_err_interface_inconsistent - einfo%typ1=p - einfo%typ2=q - ok=.false. - return - endif - enddo - einfo%kind=pm_typ_err_interface_elem - einfo%typ1=p - einfo%typ2=q - einfo%vname=abs(nt) - return - enddo outer - ok=.true. - case(pm_typ_is_rec,pm_typ_is_struct) - ok=.true. - names1=pm_name_val(context,pm_tv_name(t)) - einfo%vtyp1=p - einfo%vtyp2=q - do i=1,pm_fast_esize(names1) - nt=names1%data%i(names1%offset+i) - einfo%vname=abs(nt) - uk=1 - elem=pm_typ_find_elem(context,q,abs(nt),nt<0,& - params,uk,size(params),s,einfo) - if(elem==0) then - if(einfo%kind/=pm_typ_err_elem_clash) then - einfo%kind=merge(pm_typ_err_interface_write,& - pm_typ_err_interface,nt<0) - endif - ok=.false. - return - endif - ok=pm_typ_includes(context,& - pm_tv_arg(t,i+1),s,& - pm_typ_incl_typ,einfo) - if(.not.ok) then - einfo%kind=pm_typ_err_interface_mismatch - einfo%typ1=pm_tv_arg(t,i+1) - einfo%typ2=s - return - endif - enddo - case default - einfo%kind=pm_typ_err_interface_bad_typ - einfo%vtyp1=q - ok=.false. - end select - contains - include 'fesize.inc' - include 'ftypeof.inc' - include 'ftypeno.inc' - include 'ftiny.inc' - end function pm_interface_typ_conforms + !========================================== ! Autoconversion to proc signature type ! Returns -1 if not possible !========================================== - function pm_proc_typ_convert(context,ptyp,argtyp) result(ctyp) + function pm_proc_type_convert(context,ptyp,argtyp) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: ptyp,argtyp integer:: ctyp type(pm_ptr):: tv,tv2 integer:: i,tno integer,dimension(3):: arr - tv=pm_typ_vect(context,ptyp) - tv2=pm_typ_vect(context,argtyp) - if(pm_tv_kind(tv)/=pm_typ_is_proc.or.& - pm_tv_kind(tv2)/=pm_typ_is_proc) then + tv=pm_type_vect(context,ptyp) + tv2=pm_type_vect(context,argtyp) + if(pm_tv_kind(tv)/=pm_type_is_proc.or.& + pm_tv_kind(tv2)/=pm_type_is_proc) then ctyp=-1 return endif tno=pm_tv_arg(tv,1) do i=1,pm_tv_numargs(tv2) - if(pm_proc_typ_conforms(context,tno,& + if(pm_proc_type_conforms(context,tno,& pm_tv_arg(tv2,i))) then - arr(1)=pm_typ_new_proc + arr(1)=pm_type_new_proc arr(2)=-abs(pm_tv_name(tv2)) arr(3)=tno - ctyp=pm_new_typ(context,arr) + ctyp=pm_new_type(context,arr) return endif enddo ctyp=-1 return - end function pm_proc_typ_convert + end function pm_proc_type_convert !=========================================== ! Check that two proc_sig types conform !=========================================== - function pm_proc_typ_conforms(context,tno,tno2) result(ok) + function pm_proc_type_conforms(context,tno,tno2) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno,tno2 logical:: ok type(pm_ptr):: tv,tv2,tv_res,tv_res2 - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo integer:: i,tno_res,tno_res2 - tv=pm_typ_vect(context,tno) - tv2=pm_typ_vect(context,tno2) + tv=pm_type_vect(context,tno) + tv2=pm_type_vect(context,tno2) if(pm_tv_name(tv)/=pm_tv_name(tv2)) then @@ -2148,28 +1971,28 @@ function pm_proc_typ_conforms(context,tno,tno2) result(ok) return endif - if(.not.pm_typ_includes(context,pm_tv_arg(tv2,1),& - pm_tv_arg(tv,1),pm_typ_incl_typ,einfo)) then + if(.not.pm_type_includes(context,pm_tv_arg(tv2,1),& + pm_tv_arg(tv,1),pm_type_incl_type,einfo)) then ok=.false. return endif tno_res=pm_tv_arg(tv,2) tno_res2=pm_tv_arg(tv2,2) - tv_res=pm_typ_vect(context,tno_res) - tv_res2=pm_typ_vect(context,tno_res2) - if(pm_tv_kind(tv_res2)==pm_typ_is_undef_result) then + tv_res=pm_type_vect(context,tno_res) + tv_res2=pm_type_vect(context,tno_res2) + if(pm_tv_kind(tv_res2)==pm_type_is_undef_result) then ok=pm_tv_numargs(tv_res)==pm_tv_name(tv_res2) return else - if(.not.pm_typ_includes(context,tno_res,& - tno_res2,pm_typ_incl_equiv,einfo)) then + if(.not.pm_type_includes(context,tno_res,& + tno_res2,pm_type_incl_equiv,einfo)) then ok=.false. return endif endif ok=.true. - end function pm_proc_typ_conforms + end function pm_proc_type_conforms !================================================================= ! Find element "name" in type "tno" @@ -2180,7 +2003,7 @@ end function pm_proc_typ_conforms ! offset<0 Nested offsets detailed in stack(old_top:top) ! If offset/=0 then etype returns the type of the element !================================================================= - recursive function pm_typ_find_elem(context,tno,name,change,& + recursive function pm_type_find_elem(context,tno,name,change,& stack,top,maxstack,etype,einfo) result(offset) type(pm_context),pointer:: context integer,intent(in):: tno,name @@ -2189,7 +2012,7 @@ recursive function pm_typ_find_elem(context,tno,name,change,& integer,intent(inout):: top integer,intent(in):: maxstack integer,intent(out):: etype - type(pm_typ_einfo),intent(out):: einfo + type(pm_type_einfo),intent(out):: einfo integer:: offset,ptype,mode type(pm_ptr):: tv,tv2,nameset,info integer:: tk,i,key(2),tno2,name2 @@ -2201,45 +2024,45 @@ recursive function pm_typ_find_elem(context,tno,name,change,& endif if(tno==0) then offset=0 - einfo%kind=pm_typ_err_elem_bad_typ + einfo%kind=pm_type_err_elem_bad_type endif einfo%kind=0 einfo%typ1=tno einfo%name=name - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(tv) - offset=pm_typ_find_elem(context,pm_tv_arg(tv,i),name,change,& + offset=pm_type_find_elem(context,pm_tv_arg(tv,i),name,change,& stack,top,maxstack,etype,einfo) if(offset/=0) return enddo offset=0 - einfo%kind=pm_typ_err_elem_not_found + einfo%kind=pm_type_err_elem_not_found return - case(pm_typ_is_dref) - offset=pm_typ_find_elem(context,& - pm_typ_strip_mode(context,pm_tv_arg(tv,1),mode),& + case(pm_type_is_dref) + offset=pm_type_find_elem(context,& + pm_type_strip_mode(context,pm_tv_arg(tv,1),mode),& name,change,stack,top,& maxstack,etype,einfo) if(offset==0) then return else - offset=offset+pm_typ_dref_offset + offset=offset+pm_type_dref_offset endif - call push(pm_typ_new_dref) + call push(pm_type_new_dref) call push(name) - call push(pm_typ_add_mode(context,etype,mode,.false.)) + call push(pm_type_add_mode(context,etype,mode,.false.)) call push(tno) do i=3,pm_tv_numargs(tv) call push(pm_tv_arg(tv,i)) enddo - etype=pm_new_typ(context,stack(top-pm_tv_numargs(tv)-1:top)) + etype=pm_new_type(context,stack(top-pm_tv_numargs(tv)-1:top)) top=top-pm_tv_numargs(tv)-2 - case(pm_typ_is_struct,pm_typ_is_rec) - if(change.and.tk==pm_typ_is_rec) then - einfo%kind=pm_typ_err_elem_not_found + case(pm_type_is_struct,pm_type_is_rec) + if(change.and.tk==pm_type_is_rec) then + einfo%kind=pm_type_err_elem_not_found offset=0 return endif @@ -2256,12 +2079,12 @@ recursive function pm_typ_find_elem(context,tno,name,change,& return endif else - einfo%kind=pm_typ_err_elem_not_found + einfo%kind=pm_type_err_elem_not_found offset=0 endif - case(pm_typ_is_enveloped) + case(pm_type_is_enveloped) tno2=pm_tv_arg(tv,2) - tv2=pm_typ_vect(context,tno2) + tv2=pm_type_vect(context,tno2) nameset=pm_name_val(context,pm_tv_name(tv2)) found=.false. do i=1,pm_fast_esize(nameset) @@ -2272,15 +2095,15 @@ recursive function pm_typ_find_elem(context,tno,name,change,& endif enddo if(.not.found) then - einfo%kind=pm_typ_err_elem_not_in_interface + einfo%kind=pm_type_err_elem_not_in_interface einfo%typ1=tno2 offset=0 return endif - offset=pm_typ_find_elem(context,pm_tv_arg(tv,1),& + offset=pm_type_find_elem(context,pm_tv_arg(tv,1),& name,change,stack,top,maxstack,etype,einfo) case default - einfo%kind=pm_typ_err_elem_bad_typ + einfo%kind=pm_type_err_elem_bad_type offset=0 return end select @@ -2292,7 +2115,7 @@ subroutine push(j) top=top+1 stack(top)=j end subroutine push - end function pm_typ_find_elem + end function pm_type_find_elem ! Find offset and type for named element in struct/rec type ! Returns offset and type of element @@ -2316,7 +2139,7 @@ recursive subroutine elem_offset(context,tv,name,change,offset,etyp) return endif enddo - if(iand(pm_tv_flags(tv),pm_typ_has_embedded)/=0) offset=-1 + if(iand(pm_tv_flags(tv),pm_type_has_embedded)/=0) offset=-1 contains include 'fesize.inc' end subroutine elem_offset @@ -2332,7 +2155,7 @@ recursive subroutine indirect_offset(context,tv,name,stack,& integer,dimension(maxstack),intent(inout):: stack logical,intent(in):: change integer,intent(out):: etype,ptype - type(pm_typ_einfo),intent(out):: einfo + type(pm_type_einfo),intent(out):: einfo type(pm_ptr):: nv,tv2 integer:: i integer:: n,offset,new_etype,new_ptype,found_below,tk2 @@ -2347,16 +2170,16 @@ recursive subroutine indirect_offset(context,tv,name,stack,& n=nv%data%i(nv%offset+i) if(n<0) then new_ptype=pm_tv_arg(tv,i) - tv2=pm_typ_vect(context,new_ptype) + tv2=pm_type_vect(context,new_ptype) tk2=pm_tv_kind(tv2) - if(tk2/=pm_typ_is_struct.and.tk2/=pm_typ_is_rec) cycle + if(tk2/=pm_type_is_struct.and.tk2/=pm_type_is_rec) cycle call elem_offset(context,tv2,name,change,offset,new_etype) if(offset>0) then if(top+4>maxstack) then call pm_panic('Structure embedding too complex') endif if(found) then - einfo%kind=pm_typ_err_elem_clash + einfo%kind=pm_type_err_elem_clash einfo%vtyp1=new_ptype einfo%vtyp2=ptype return @@ -2378,7 +2201,7 @@ recursive subroutine indirect_offset(context,tv,name,stack,& maxstack,top,change,new_etype,new_ptype,einfo) if(einfo%kind==0) then if(found_below>0) then - einfo%kind=pm_typ_err_elem_clash + einfo%kind=pm_type_err_elem_clash einfo%vtyp1=new_ptype einfo%vtyp2=ptype else @@ -2386,7 +2209,7 @@ recursive subroutine indirect_offset(context,tv,name,stack,& ptype=new_ptype endif found_below=found_below+1 - elseif(einfo%kind==pm_typ_err_elem_clash) then + elseif(einfo%kind==pm_type_err_elem_clash) then clash_below=.true. top=top-2 return @@ -2401,7 +2224,7 @@ recursive subroutine indirect_offset(context,tv,name,stack,& elseif(found_below>1.and.found) then einfo%kind=0 elseif(.not.found.and.found_below==0) then - einfo%kind=pm_typ_err_elem_not_found + einfo%kind=pm_type_err_elem_not_found endif contains include 'fesize.inc' @@ -2420,7 +2243,7 @@ recursive subroutine pm_indirect_include(context,tno,tno2,stack,& integer,intent(inout):: top integer,intent(in):: maxstack integer,dimension(maxstack),intent(inout):: stack - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo integer,intent(out):: tno_match integer,intent(out):: status @@ -2462,21 +2285,21 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& integer,intent(inout):: top integer,intent(in):: dir,maxstack,base integer,dimension(maxstack),intent(inout):: stack - type(pm_typ_einfo):: einfo + type(pm_type_einfo):: einfo integer,intent(out):: tno_match logical:: ok type(pm_ptr):: tv,name integer:: i,j,start,finish,tk integer:: n if(tno2==0) return - tv=pm_typ_vect(context,tno2) + tv=pm_type_vect(context,tno2) tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_par_kind) + case(pm_type_is_par_kind) ok=test_indirect_include(context,dir,tno,pm_tv_arg(tv,1),stack,& maxstack,base,top,einfo,tno_match) return - case(pm_typ_is_any) + case(pm_type_is_any) do i=1,pm_tv_numargs(tv) if(.not.test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& maxstack,base,top,einfo,tno_match)) then @@ -2486,7 +2309,7 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& enddo ok=.true. return - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(tv) if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& maxstack,base,top,einfo,tno_match)) then @@ -2496,7 +2319,7 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& enddo ok=.false. return - case(pm_typ_is_except) + case(pm_type_is_except) if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,1),stack,& maxstack,base,top,einfo,tno_match)) then ok=.not.test_indirect_include(context,dir,tno,pm_tv_arg(tv,2),stack,& @@ -2505,7 +2328,7 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& ok=.false. endif return - case(pm_typ_is_struct,pm_typ_is_rec) + case(pm_type_is_struct,pm_type_is_rec) continue case default ok=.false. @@ -2513,7 +2336,7 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& end select ok=.false. - if(iand(pm_tv_flags(tv),pm_typ_has_embedded)/=0) then + if(iand(pm_tv_flags(tv),pm_type_has_embedded)/=0) then if(top+2>maxstack) call pm_panic('Program too complex (nested embeds)') top=top+2 if(dir>0) then @@ -2529,8 +2352,8 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& stack(top-1)=i+1 stack(top)=n if(n<0) then - if(pm_typ_includes(context,tno,pm_tv_arg(tv,i),& - pm_typ_incl_indirect,einfo)) then + if(pm_type_includes(context,tno,pm_tv_arg(tv,i),& + pm_type_incl_indirect,einfo)) then ! Check that this element is not shadowed by name do j=base+2,top-2,2 if(stack(j)==n) cycle outer @@ -2558,7 +2381,7 @@ recursive function test_indirect_include(context,dir,tno,tno2,stack,& end function test_indirect_include ! Concrete only version of a type (used/usable only for returns from builtin functions) - recursive function pm_typ_as_concrete(context,tno,params,isstatic,iserr) result(tno2) + recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno integer,dimension(:),intent(in):: params @@ -2569,16 +2392,16 @@ recursive function pm_typ_as_concrete(context,tno,params,isstatic,iserr) result( integer:: tk,nt isstatic=.true. if(present(iserr)) iserr=.false. - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_basic,pm_typ_is_single_name,& - pm_typ_is_proc,pm_typ_is_value,pm_typ_is_const,& - pm_typ_is_undef_result,pm_typ_is_poly) + case(pm_type_is_basic,pm_type_is_single_name,& + pm_type_is_proc,pm_type_is_value,pm_type_is_const,& + pm_type_is_undef_result,pm_type_is_poly) tno2=tno - case(pm_typ_is_user) - tno2=pm_user_typ_body(context,tno) - case(pm_typ_is_any,pm_typ_is_all,pm_typ_is_contains) + case(pm_type_is_user) + tno2=pm_user_type_body(context,tno) + case(pm_type_is_any,pm_type_is_all,pm_type_is_contains) if(present(iserr)) then iserr=.true. isstatic=.true. @@ -2597,37 +2420,37 @@ subroutine remake(n) a(2)=pm_tv_name(tv) if(present(iserr)) then do i=1,n - a(i+2)=pm_typ_as_concrete(context,pm_tv_arg(tv,i),params,isstatic,iserr) + a(i+2)=pm_type_as_concrete(context,pm_tv_arg(tv,i),params,isstatic,iserr) if(iserr) return enddo else do i=1,n - a(i+2)=pm_typ_as_concrete(context,pm_tv_arg(tv,i),params,isstatic) + a(i+2)=pm_type_as_concrete(context,pm_tv_arg(tv,i),params,isstatic) enddo endif - tno2=pm_new_typ(context,a) + tno2=pm_new_type(context,a) end subroutine remake - end function pm_typ_as_concrete + end function pm_type_as_concrete - recursive function pm_typ_remove_params(context,tno,params) result(tno2) + recursive function pm_type_remove_params(context,tno,params) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno integer,dimension(:),intent(in):: params integer:: tno2 type(pm_ptr):: tv integer:: tk,argnum - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) - if(tk==pm_typ_is_user) then - tno2=pm_user_typ_body(context,tno) - elseif(tk==pm_typ_is_param) then + if(tk==pm_type_is_user) then + tno2=pm_user_type_body(context,tno) + elseif(tk==pm_type_is_param) then argnum=pm_tv_name(tv) if(params(argnum)>=0) then tno2=params(argnum) else tno2=pm_tv_arg(tv,1) endif - elseif(iand(pm_tv_flags(tv),pm_typ_has_params)/=0) then + elseif(iand(pm_tv_flags(tv),pm_type_has_params)/=0) then call remake(pm_tv_numargs(tv)) else tno2=tno @@ -2640,15 +2463,14 @@ subroutine remake(n) a(1)=tk a(2)=pm_tv_name(tv) do i=1,n - a(i+2)=pm_typ_remove_params(context,pm_tv_arg(tv,i),params) + a(i+2)=pm_type_remove_params(context,pm_tv_arg(tv,i),params) enddo - tno2=pm_new_typ(context,a) + tno2=pm_new_type(context,a) end subroutine remake - end function pm_typ_remove_params + end function pm_type_remove_params - ! Get vector of integer representation of type - function pm_typ_vect(context,tno) result(typ) + function pm_type_vect(context,tno) result(typ) type(pm_context),pointer:: context integer,intent(in):: tno type(pm_ptr):: typ,dict @@ -2658,17 +2480,17 @@ function pm_typ_vect(context,tno) result(typ) if(pm_debug_level>0) then if(t<1.or.t>pm_dict_size(context,dict)) then write(*,*) 'tno=',t,tno,pm_dict_size(context,dict) - call pm_panic('pm_typ_vect') + call pm_panic('pm_type_vect') endif endif typ=pm_dict_key(context,dict,t) - end function pm_typ_vect + end function pm_type_vect ! Type kind from integer type vector function pm_tv_kind(typ) result(k) type(pm_ptr),intent(in):: typ integer:: k - k=iand(typ%data%i(typ%offset),pm_typ_kind_mask) + k=iand(typ%data%i(typ%offset),pm_type_kind_mask) end function pm_tv_kind ! Type kind from integer type vector @@ -2708,7 +2530,7 @@ function pm_tv_numargs(typ) result(num) end function pm_tv_numargs ! Display type as user-readable string - function pm_typ_as_string(context,tno,distr) result(str) + function pm_type_as_string(context,tno,distr) result(str) type(pm_context),pointer:: context integer,intent(in):: tno logical,intent(in),optional:: distr @@ -2719,11 +2541,11 @@ function pm_typ_as_string(context,tno,distr) result(str) str='any' else n=1 - call typ_to_str(context,tno,str,n,tuple=.false.,distr=distr) + call pm_type_to_string(context,tno,str,n,tuple=.false.,distr=distr) endif - end function pm_typ_as_string + end function pm_type_as_string - recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) + recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) type(pm_context),pointer:: context integer,intent(in):: typno character(len=256),intent(inout):: str @@ -2753,15 +2575,15 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(add_char('*Internal error(>size)*')) return return endif - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) nv=pm_dict_val(context,context%tcache,int(tno,pm_ln)) narg=pm_tv_numargs(tv) select case(tk) - case(pm_typ_is_user,pm_typ_is_basic) + case(pm_type_is_user,pm_type_is_basic) name=pm_tv_name(tv) if(name<0) then - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) return endif name=pm_name_stem(context,name) @@ -2786,19 +2608,19 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) else if(add_char('_of(')) return endif - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return else if(add_char('[')) return do i=1,narg-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,narg),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n) if(add_char(']')) return endif elseif(name==sym_pm_ref_type) then - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) else call pm_name_string(context,name,str(n:)) n=len_trim(str)+1 @@ -2807,20 +2629,20 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(narg>0) then if(add_char('(')) return do i=1,narg-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,narg),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n) if(add_char(')')) return endif - if(tk==pm_typ_is_user.and.(pm_opts%show_members)) then + if(tk==pm_type_is_user.and.(pm_opts%show_members)) then nv2=pm_dict_val(context,context%tcache,int(tno,pm_ln)) tno2=int(nv2%offset) if(tno2>0.and.tno20.and..not.present(noequiv)) then if(show_equiv(int(name),tno2,tno)) return endif - if(tk==pm_typ_is_struct) then + if(tk==pm_type_is_struct) then if(add_char('struct ')) return else if(add_char('rec ')) return @@ -2895,23 +2717,13 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) n=len_trim(str)+1 if(n>len(str)-10) return if(add_char(':')) return - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(ilen(str)-10) return - if(iand(pm_tv_flags(tv),pm_typ_has_distributed)/=0) then + if(iand(pm_tv_flags(tv),pm_type_has_distributed)/=0) then if(add_char('*distr*')) return endif - case(pm_typ_is_dref) + case(pm_type_is_dref) if(pm_opts%show_all_ref) then if(pm_tv_name(tv)==pm_dref_is_dot) then if(add_char('^.(')) return @@ -2951,15 +2763,15 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(add_char('(')) return endif do i=1,pm_tv_numargs(tv)-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) if(add_char(')')) return else - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) endif - case(pm_typ_is_array) + case(pm_type_is_array) name=pm_tv_name(tv) if(name==sym_var) then if(add_char('varray(')) return @@ -2968,17 +2780,17 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) else if(add_char('array(')) return endif - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(',')) return - call typ_to_str(context,pm_tv_arg(tv,2),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n) if(add_char(')')) return - case(pm_typ_is_poly) + case(pm_type_is_poly) if(add_char('*')) return - call bracket(1,pm_typ_is_includes,pm_typ_is_all,pm_typ_is_any,pm_typ_is_except) - case(pm_typ_is_value) + call bracket(1,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) + case(pm_type_is_value) if(add_char('''')) return if(pm_tv_name(tv)==0) then - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) else nv=pm_dict_val(context,context%tcache,int(tno,pm_ln)) if(pm_fast_vkind(nv)==pm_logical) then @@ -2992,39 +2804,39 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) endif n=len_trim(str)+1 endif - case(pm_typ_is_const) + case(pm_type_is_const) if(add_char('fix(')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return - case(pm_typ_is_except) - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + case(pm_type_is_except) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(' except ')) return - call typ_to_str(context,pm_tv_arg(tv,2),str,n) - case(pm_typ_is_any) - call bracket(1,pm_typ_is_except,pm_typ_is_except,pm_typ_is_except,pm_typ_is_except) + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n) + case(pm_type_is_any) + call bracket(1,pm_type_is_except,pm_type_is_except,pm_type_is_except,pm_type_is_except) do i=2,pm_tv_numargs(tv) if(add_char(' or ')) return - call bracket(i,pm_typ_is_except,pm_typ_is_except,pm_typ_is_except,pm_typ_is_except) + call bracket(i,pm_type_is_except,pm_type_is_except,pm_type_is_except,pm_type_is_except) enddo - case(pm_typ_is_all) - call bracket(1,pm_typ_is_any,pm_typ_is_except,pm_typ_is_except,pm_typ_is_except) + case(pm_type_is_all) + call bracket(1,pm_type_is_any,pm_type_is_except,pm_type_is_except,pm_type_is_except) do i=2,pm_tv_numargs(tv) if(add_char(' and ')) return - call bracket(i,pm_typ_is_any,pm_typ_is_except,pm_typ_is_except,pm_typ_is_except) + call bracket(i,pm_type_is_any,pm_type_is_except,pm_type_is_except,pm_type_is_except) enddo - case(pm_typ_is_includes) - call bracket(1,pm_typ_is_any,pm_typ_is_all,pm_typ_is_except,pm_typ_is_except) + case(pm_type_is_includes) + call bracket(1,pm_type_is_any,pm_type_is_all,pm_type_is_except,pm_type_is_except) if(add_char(' inc ')) return - call bracket(2,pm_typ_is_any,pm_typ_is_all,pm_typ_is_except,pm_typ_is_except) - case(pm_typ_is_contains) + call bracket(2,pm_type_is_any,pm_type_is_all,pm_type_is_except,pm_type_is_except) + case(pm_type_is_contains) if(add_char('contains(')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return - case(pm_typ_is_has) + case(pm_type_is_has) if(add_char('.')) return - call bracket(1,pm_typ_is_includes,pm_typ_is_all,pm_typ_is_any,pm_typ_is_except) - call typ_to_str(context,pm_tv_arg(tv,1),str,n) - case(pm_typ_is_proc) + call bracket(1,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + case(pm_type_is_proc) name=pm_tv_name(tv) if(name>0) then if(add_char('$')) return @@ -3041,15 +2853,15 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(pm_opts%show_variants) then if(add_char(' -- {')) return do i=1,pm_tv_numargs(tv)-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) if(add_char('}')) return endif elseif(name==0) then if(add_char('proc')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) else if(add_char('proc ')) return nv2=pm_name_val(context,-name) @@ -3062,17 +2874,17 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) endif n=len_trim(str)+1 if(n>len(str)-10) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) endif - case(pm_typ_is_proc_sig) + case(pm_type_is_proc_sig) name=pm_tv_name(tv) if(name/=sym_proc) then if(add_char(trim(pm_name_as_string(context,name)))) return endif - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char('->')) return - call typ_to_str(context,pm_tv_arg(tv,2),str,n) - case(pm_typ_is_undef_result) + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n) + case(pm_type_is_undef_result) name=pm_tv_name(tv) if(add_char('(')) return do i=1,name-1 @@ -3080,26 +2892,26 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) enddo if(add_char('_')) return if(add_char(')')) return - case(pm_typ_is_amp) + case(pm_type_is_amp) if(add_char('&')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) - case(pm_typ_is_vect) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + case(pm_type_is_vect) if(add_char('^^(')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return - case(pm_typ_is_par_kind) + case(pm_type_is_par_kind) name=pm_tv_name(tv) if(add_char(trim(sym_names(name)))) return if(add_char(' ')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) - case(pm_typ_is_param,pm_typ_is_params) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + case(pm_type_is_param,pm_type_is_params) if(add_char('$')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) - case(pm_typ_is_type) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) + case(pm_type_is_type) if(add_char('<')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char('>')) return - case(pm_typ_is_bottom) + case(pm_type_is_bottom) if(add_char(' _ ')) return case default if(add_char('?')) return @@ -3134,27 +2946,27 @@ end function add_char subroutine bracket(i,tk1,tk2,tk3,tk4) integer,intent(in):: i,tk1,tk2,tk3,tk4 integer:: tk - tk=pm_typ_kind(context,pm_tv_arg(tv,i)) + tk=pm_type_kind(context,pm_tv_arg(tv,i)) if(tk==tk1.or.tk==tk2.or.tk==tk3.or.tk==tk4) then if(add_char('(')) return - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(')')) return else - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) endif end subroutine bracket function show_equiv(name,templ,typ) result(ok) integer,intent(in):: name,templ,typ logical:: ok - integer,dimension(pm_max_typ_args):: params + integer,dimension(pm_max_type_args):: params integer:: i,m,name2 logical:: tuple params=-1 - ok=pm_typ_extract_params(context,templ,typ,params) + ok=pm_type_extract_params(context,templ,typ,params) if(ok) then m=0 - do i=1,pm_max_typ_args + do i=1,pm_max_type_args if(params(i)>0) m=i enddo name2=pm_name_stem(context,name) @@ -3168,7 +2980,7 @@ function show_equiv(name,templ,typ) result(ok) if(add_char(merge('[','(',tuple))) return do i=1,m if(params(i)>0) then - call typ_to_str(context,params(i),str,n) + call pm_type_to_string(context,params(i),str,n) endif if(i0) then + call print_comp_op_block(context,iunit,op,first_index,vars,dict,values,2,masked,wstack,vsets,oindex) + endif write(iunit,'(a)') '}' end subroutine print_comp_proc - subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked) + subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit - integer,dimension(*):: op,vars + integer,dimension(*),intent(in):: op,vars integer,intent(in):: index,depth type(pm_ptr),intent(in):: dict type(pm_ptr),dimension(*),intent(in):: values logical,intent(in):: masked + integer,dimension(:),optional,intent(in):: wstack + logical,intent(in),optional:: vsets + integer,dimension(:),intent(in),optional:: oindex character(len=wcode_file_cols):: line character(len=wcode_file_cols):: location - integer:: nargs,nret,opcode,opcode2,flags,last_arg,arg1,i,nblocks,j + integer:: nargs,nret,opcode,opcode2,flags,last_arg,arg1,i,nblocks,j,loc,vset,bset logical:: shared type(pm_ptr):: p opcode=op(comp_op_opcode+index) @@ -2175,10 +2194,22 @@ subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked) nargs=iand(op(comp_op_nargs+index),comp_op_nargs_mask) nret=iand(op(comp_op_nargs+index),comp_op_nret_mask)/comp_op_nret_div shared=iand(op(comp_op_nargs+index),comp_op_shared)/=0 - location=trim(pm_name_as_string(context,iand(op(index+comp_op_line),modl_mult-1)))//& - ':'//pm_int_as_string(op(index+comp_op_line)/modl_mult) + loc=op(index+comp_op_line) + vset=-1 + if(present(vsets)) then + if(vsets) vset=loc + !write(*,*) '@@@@ loc=',loc,op_names(opcode) + loc=wstack(loc) + endif + bset=0 + if(loc<0) then + bset=loc + loc=wstack(size(wstack)+loc) + endif + location=trim(pm_name_as_string(context,iand(loc,modl_mult-1)))//& + ':'//pm_int_as_string(loc/modl_mult) -! write(*,*) 'NAME=',iand(op(index+comp_op_line),modl_mult-1) +! write(*,*) 'NAME=',iand(loc,modl_mult-1) !!$ write(*,*) 'op->',op_names(opcode),opcode,opcode2,op(index+comp_op_nargs),& !!$ (op(index+comp_op_arg0+i),i=1,nargs-1),'#',nret @@ -2230,18 +2261,23 @@ subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked) line(len(line)-len_trim(location)+1:)=location write(iunit,'(a)') line if(nblocks>0) then + if(bset/=0) call print_bset(context,iunit,bset,wstack,vars,values,oindex,depth) call print_comp_op_block(context,iunit,op,op(index+comp_op_arg0+1),& - vars,dict,values,min(20,depth+2),masked) + vars,dict,values,min(20,depth+2),masked,wstack,vsets,oindex) if(nblocks>1) then write(iunit,'(a)') repeat(' ',depth)//'} --- {' + if(bset/=0) call print_bset(context,iunit,bset,wstack,vars,values,oindex,depth) call print_comp_op_block(context,iunit,op,op(index+comp_op_arg0+2),& - vars,dict,values,min(20,depth+2),masked) + vars,dict,values,min(20,depth+2),masked,wstack,vsets,oindex) endif write(iunit,'(a)') repeat(' ',depth)//'}' endif + if(present(vsets)) then + if(vsets) call print_vset(context,iunit,op(index+comp_op_line),wstack,vars,values,oindex,depth) + endif end subroutine print_comp_op - subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,masked) + subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit integer,dimension(*),intent(in):: op,vars @@ -2249,12 +2285,20 @@ subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,mas type(pm_ptr),dimension(*),intent(in):: values integer,intent(in):: index,depth logical,intent(in):: masked + integer,dimension(:),optional,intent(in):: wstack + logical,intent(in),optional:: vsets + integer,dimension(:),intent(in),optional:: oindex integer::i !write(*,*) 'BLOCK>',index i=index - do while(i>0) - call print_comp_op(context,iunit,op,i,vars,dict,values,depth,masked) - i=op(i+comp_op_link) + do while(i/=0) + if(i>0) then + call print_comp_op(context,iunit,op,i,vars,dict,values,depth,masked,wstack,vsets,oindex) + i=op(i+comp_op_link) + else + call print_comp_op(context,iunit,wstack,i,vars,dict,values,depth,masked,wstack,vsets,oindex) + i=wstack(-i+comp_op_link) + endif enddo end subroutine print_comp_op_block @@ -2325,9 +2369,9 @@ recursive subroutine printv(index,addtype) call printv(v1,.true.) call append(')') tno2=var(v1+2)/cvar_flag_mult - tk=pm_typ_kind(context,tno2) - if(tk==pm_typ_is_struct.or.tk==pm_typ_is_rec) then - ename=abs(pm_typ_elem_name(context,tno2,v2)) + tk=pm_type_kind(context,tno2) + if(tk==pm_type_is_struct.or.tk==pm_type_is_rec) then + ename=abs(pm_type_elem_name(context,tno2,v2)) if(ename>=sym_d1.and.ename<=sym_d7) then call append('.'//pm_int_as_string(v2)) else @@ -2367,9 +2411,9 @@ recursive subroutine printv(index,addtype) case(v_is_array) call group(index,v1,v2,'<','>',.false.) case(v_is_struct) - tk=pm_typ_kind(context,tno) - if(tk==pm_typ_is_struct.or.tk==pm_typ_is_rec) then - call group(index,v1,v2,trim(pm_name_as_string(context,pm_typ_elem_name(context,tno,0)))//& + tk=pm_type_kind(context,tno) + if(tk==pm_type_is_struct.or.tk==pm_type_is_rec) then + call group(index,v1,v2,trim(pm_name_as_string(context,pm_type_elem_name(context,tno,0)))//& '{','}',.false.) else call group(index,v1,v2,'{','}',.true.) @@ -2392,7 +2436,7 @@ recursive subroutine printv(index,addtype) call append('???'//pm_int_as_string(kind)) end select if(addtype) then - call append(':'//pm_typ_as_string(context,tno)) + call append(':'//pm_type_as_string(context,tno)) endif end subroutine printv @@ -2440,13 +2484,85 @@ end subroutine append end subroutine print_cvar + subroutine print_vset(context,iunit,vset,wstack,var,values,oindex,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,vset,depth + integer,dimension(:),intent(in):: wstack + integer,dimension(*),intent(in):: var + type(pm_ptr),dimension(*),intent(in):: values + integer,dimension(*):: oindex + character(len=wcode_file_cols):: line + integer:: i,j,n + !write(*,*) 'vset' + line=' ' + line(depth+1:depth+1)='[' + j=depth+3 + n=wstack(vset+2) + do i=1,n + call print_cvar(context,iunit,var,oindex(wstack(vset+i+2)/acc_mult),values,.false.,depth,line,j) + call print_acc(iunit,line,j,wstack(vset+i+2),depth) + call append_to(iunit,line,j,'('//trim(pm_int_as_string(wstack(vset+i+2)/acc_mult))//')',.false.,depth) + call append_to(iunit,line,j,' ',.false.,depth) + enddo + call append_to(iunit,line,j,']',.true.,depth) + end subroutine print_vset + + subroutine print_bset(context,iunit,bset,wstack,var,values,oindex,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,bset,depth + integer,dimension(:),intent(in):: wstack + integer,dimension(*),intent(in):: var + type(pm_ptr),dimension(*),intent(in):: values + integer,dimension(*):: oindex + character(len=wcode_file_cols):: line + integer:: i,j,wmax + wmax=size(wstack) + line=' ' + line(depth+1:depth+1)='|' + j=depth+3 + i=wstack(wmax+bset+1) + do while(i/=0) + call print_cvar(context,iunit,var,oindex(wstack(wmax+i)/acc_mult),values,.false.,depth,line,j) + call print_acc(iunit,line,j,wstack(wmax+i),depth) + call append_to(iunit,line,j,'('//trim(pm_int_as_string(wstack(wmax+i)/acc_mult))//')',.false.,depth) + call append_to(iunit,line,j,' ',.false.,depth) + i=wstack(wmax+i+1) + enddo + call append_to(iunit,line,j,'|',.true.,depth) + end subroutine print_bset + + subroutine print_acc(iunit,str,i,acc,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + integer,intent(in):: acc + integer,intent(in):: depth + character(len=3):: part + integer:: j + part=':' + j=1 + if(iand(acc,acc_read)/=0) then + j=j+1 + part(j:j)='r' + endif + if(iand(acc,acc_write)/=0) then + j=j+1 + part(j:j)='w' + endif + if(iand(acc,acc_alloc)/=0) then + j=j+1 + part(j:j)='a' + endif + call append_to(iunit,str,i,part(1:j),.false.,depth) + end subroutine print_acc + subroutine append_to(iunit,str,i,part,break,depth) integer,intent(in):: iunit character(len=*),intent(inout):: str integer,intent(inout):: i character(len=*),intent(in):: part - logical,intent(in):: break integer,intent(in):: depth + logical,intent(in):: break integer:: n n=len(part) if(i+n>len(str)) then diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 72d4b35..359ec3f 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -173,8 +173,8 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) wcd%true_obj%data%l(wcd%true_obj%offset)=.true. wcd%false_obj=pm_new_small(context,pm_logical,1_pm_p) wcd%false_obj%data%l(wcd%false_obj%offset)=.false. - wcd%true_name=pm_new_value_typ(wcd%context,wcd%true_obj) - wcd%false_name=pm_new_value_typ(wcd%context,wcd%false_obj) + wcd%true_name=pm_new_value_type(wcd%context,wcd%true_obj) + wcd%false_name=pm_new_value_type(wcd%context,wcd%false_obj) if(pm_is_compiling) then wcd%typeset=pm_set_new(wcd%context,32_pm_ln) endif @@ -535,8 +535,8 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) if(.not.pm_fast_isnull(p)) then if(cnode_flags_set(p,var_flags,var_is_varg)) then typ=get_var_type(wcd,p,rv) - tv=pm_typ_vect(wcd%context,typ) - if(pm_tv_kind(tv)==pm_typ_is_tuple) then + tv=pm_type_vect(wcd%context,typ) + if(pm_tv_kind(tv)==pm_type_is_tuple) then xpar=pm_tv_numargs(tv) do i=1,xpar typ=pm_tv_arg(tv,i) @@ -1352,10 +1352,10 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) cvar_ptr(wcd,i,kk-3)) enddo else - typ=pm_typ_strip_mode(wcd%context,get_arg_type(wcd,cnode_arg(args,1),rv),j) - tv=pm_typ_vect(wcd%context,typ) + typ=pm_type_strip_mode(wcd%context,get_arg_type(wcd,cnode_arg(args,1),rv),j) + tv=pm_type_vect(wcd%context,typ) do kk=4,nargs - if(pm_typ_needs_storage(wcd%context,pm_tv_arg(tv,kk-3))) then + if(pm_type_needs_storage(wcd%context,pm_tv_arg(tv,kk-3))) then slot=arg_slot(wcd,cnode_arg(args,kk)) call comp_assign_slots(wcd,callnode,& cvar_alloc_elem(wcd,i,kk-3),& @@ -1375,9 +1375,9 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref,sym_method_call) i=rvv(cnode_get_num(callnode,call_index)) - if(i>pm_typ_dref_offset/2) then + if(i>pm_type_dref_offset/2) then j=op_elem_ref - i=i-pm_typ_dref_offset + i=i-pm_type_dref_offset else j=op_elem endif @@ -1622,7 +1622,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) if(pm_is_compiling) then if(debug_wcode) then write(*,*) 'RETURN-ACTUAL[',n,']:',& - trim(pm_typ_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) endif i=wcd%retvar do kk=1,nargs @@ -1638,7 +1638,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) do n=1,nargs if(debug_wcode) then write(*,*) 'RETURN[',n,']:',& - trim(pm_typ_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) endif if(pm_is_compiling) then slot=cvar_strip_alias(wcd,arg_slot_in_frame(wcd,cnode_arg(args,n),wcd%base)) @@ -1646,7 +1646,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) if(debug_wcode) then write(*,*) 'RETURN ASSN',& - trim(pm_typ_as_string(wcd%context,& + trim(pm_type_as_string(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))) endif @@ -1657,12 +1657,12 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) cvar_kind(wcd,slot)==v_is_group.and.& cvar_v2(wcd,slot)/=v_is_array).and.& wcd%loop_extra_arg==0.and..not.wcd%proc_shared_inline.and.& - pm_typ_get_mode(wcd%context,& + pm_type_get_mode(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))>=sym_mirrored& .or.cvar_kind(wcd,slot2)==v_is_chan_vect) then if(debug_wcode) then write(*,*) 'RETURN actual ASSN',cvar_kind(wcd,slot),& - trim(pm_typ_as_string(wcd%context,& + trim(pm_type_as_string(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))) endif @@ -1908,9 +1908,9 @@ subroutine each_proc_body enddo else typ=check_arg_type(wcd,args,rv,j) - tv=pm_typ_vect(wcd%context,typ) + tv=pm_type_vect(wcd%context,typ) do i=0,n-1 - if(pm_typ_needs_storage(wcd%context,pm_tv_arg(tv,i+1))) then + if(pm_type_needs_storage(wcd%context,pm_tv_arg(tv,i+1))) then call comp_assign_slots(wcd,callnode,& cvar_alloc_elem(wcd,ii,i+1),& rtns(j,i),& @@ -1920,10 +1920,10 @@ subroutine each_proc_body endif else i=check_arg_type(wcd,args,rv,j) - v=pm_typ_vect(wcd%context,i) - if(pm_tv_kind(v)==pm_typ_is_struct) then + v=pm_type_vect(wcd%context,i) + if(pm_tv_kind(v)==pm_type_is_struct) then call wc_call(wcd,callnode,op_struct,i,n+2,1,ve) - elseif(pm_tv_kind(v)==pm_typ_is_rec) then + elseif(pm_tv_kind(v)==pm_type_is_rec) then call wc_call(wcd,callnode,op_rec,i,n+2,1,ve) else call pm_panic('Wcode each proc') @@ -2313,7 +2313,7 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) !!$ if(pm_is_compiling.and..false.) then !!$ if(nret>0.and.extra_ve==0) then !!$ tno=check_arg_type_with_mode(wcd,args,rv,1) -!!$ if(pm_typ_get_mode(wcd%context,tno)>=sym_mirrored) then +!!$ if(pm_type_get_mode(wcd%context,tno)>=sym_mirrored) then !!$ ok=.false. !!$ return !!$ endif @@ -2524,7 +2524,7 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre write(*,*) 'INLINE PAR TYPES>>' do i=1,nargs p=cnode_arg(args,i) - write(*,*) 'Par[',i,'] {',trim(pm_typ_as_string(wcd%context,get_arg_type(wcd,p,old_rv))),'#',& + write(*,*) 'Par[',i,'] {',trim(pm_type_as_string(wcd%context,get_arg_type(wcd,p,old_rv))),'#',& arg_slot(wcd,cnode_arg(args,i)),'##',p%offset,wcd%base,old_rv%offset call pm_dump_tree(wcd%context,6,old_rv,2) call dump_cvar(wcd,6,arg_slot(wcd,cnode_arg(args,i)),nonest=.true.) @@ -2610,8 +2610,8 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre call wcode_error(wcd,callnode,'tno==-1') endif if(tno/=pm_tiny_int.and.tno/=-1) then - tv=pm_typ_vect(wcd%context,tno) - if(pm_tv_kind(tv)/=pm_typ_is_tuple) then + tv=pm_type_vect(wcd%context,tno) + if(pm_tv_kind(tv)/=pm_type_is_tuple) then wcd%top=wcd%top+1 wcd%rdata(wcd%top)=& arg_slot_in_frame(wcd,cnode_arg(args,i),wcd%oldbase) @@ -3963,7 +3963,7 @@ function alloc_param_var(wcd,typ,isref,iskey,isshared,name) result(k) logical,intent(in):: isref,iskey,isshared integer:: k integer:: flags - !write(*,*) 'PARAM>>',trim(pm_typ_as_string(wcd%context,typ)) + !write(*,*) 'PARAM>>',trim(pm_type_as_string(wcd%context,typ)) if(pm_is_compiling) then flags=v_is_param if(isref) flags=ior(flags,v_is_ref) @@ -4007,7 +4007,7 @@ function alloc_general_var(wcd,var,rv) result(k) if(debug_wcode) then write(*,*) 'ALLOC GENERAL VAR',cnode_get_num(var,var_index),';',k,'::',cvar_kind(wcd,k),':',& trim(pm_name_as_string(wcd%context,cnode_get_name(var,var_name))),& - ':',trim(pm_typ_as_string(wcd%context,typ)) + ':',trim(pm_type_as_string(wcd%context,typ)) endif else k=alloc_var(wcd,0) @@ -4124,11 +4124,11 @@ function check_arg_type(wcd,args,rv,n) result(tno) var=cnode_arg(args,n) k=cnode_get_num(var,cnode_kind) if(k==cnode_is_const) then - tno=pm_typ_strip_mode(wcd%context,cnode_get_num(var,node_args+1),mode) + tno=pm_type_strip_mode(wcd%context,cnode_get_num(var,node_args+1),mode) return endif i=cnode_get_num(var,var_index) - tno=pm_typ_strip_mode(wcd%context,rv%data%i(rv%offset+i),mode) + tno=pm_type_strip_mode(wcd%context,rv%data%i(rv%offset+i),mode) contains include 'ftypeof.inc' end function check_arg_type @@ -4186,7 +4186,7 @@ function strip_mode_for_interp(wcd,tno) result(tno2) if(pm_is_compiling) then tno2=tno else - tno2=pm_typ_strip_mode(wcd%context,tno,mode) + tno2=pm_type_strip_mode(wcd%context,tno,mode) endif end function strip_mode_for_interp @@ -4445,12 +4445,12 @@ subroutine wc_p_arg(wcd,arg,isret,rv,ve,keep_ctime_const) endif else tno=cnode_get_num(arg,node_args+1) - tno=pm_typ_strip_mode(wcd%context,tno,mode) + tno=pm_type_strip_mode(wcd%context,tno,mode) if(tno>pm_null.and.& tno<=pm_string.or.tno==pm_string_type) then call wc(wcd,cvar_const(wcd,arg)) elseif(keep_ctime_const) then - if(pm_typ_kind(wcd%context,tno)==pm_typ_is_value) then + if(pm_type_kind(wcd%context,tno)==pm_type_is_value) then call wc(wcd,cvar_const(wcd,arg)) endif endif @@ -4547,7 +4547,7 @@ recursive subroutine comp_get_elem(wcd,op,dest,asource,elem) case(v_is_basic,v_is_elem,v_is_unit_elem,v_is_sub,v_is_vsub,& v_is_vect_wrapped,v_is_chan_vect) if(cvar_kind(wcd,dest)==v_is_group) then - tv=pm_typ_vect(wcd%context,cvar_type(wcd,dest)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,dest)) call comp_alias_slots(wcd,dest,& cvar_alloc_elem(wcd,source,elem)) else @@ -4606,7 +4606,7 @@ subroutine comp_get_subs(wcd,n,aparent,asubs) !!$ call dump_cvar(wcd,6,aparent) parent=cvar_strip_alias(wcd,aparent) subs=cvar_strip_alias(wcd,asubs) - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) if(cvar_kind(wcd,parent)==v_is_group) then call cvar_set_info(wcd,n,v_is_vsub,& cvar_ptr(wcd,parent,1),subs,pm_tv_arg(tv,1)) @@ -4626,7 +4626,7 @@ function comp_subs(wcd,parent,subs) result(n) integer,intent(in):: parent,subs integer:: n type(pm_ptr):: tv - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) n=cvar_alloc_slots(wcd,3) call comp_get_subs(wcd,n,parent,subs) end function comp_subs @@ -4911,16 +4911,16 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) elseif(typ<=pm_string) then n=cvar_alloc_entry(wcd,v_is_basic,name,flags,typ) else - tv=pm_typ_vect(wcd%context,typ) + tv=pm_type_vect(wcd%context,typ) tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_basic) + case(pm_type_is_basic) n=cvar_alloc_entry(wcd,v_is_basic,name,flags,typ) call add_to_typeset(wcd,typ) - case(pm_typ_is_struct,pm_typ_is_rec) + case(pm_type_is_struct,pm_type_is_rec) nflags=pm_tv_flags(tv) - if(iand(nflags,pm_typ_is_soa)/=0.or.& - iand(nflags,pm_typ_has_storage)==0)then + if(iand(nflags,pm_type_is_soa)/=0.or.& + iand(nflags,pm_type_has_storage)==0)then m=pm_tv_numargs(tv) n=cvar_alloc_slots(wcd,3+m) v1=m @@ -4930,24 +4930,24 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) enddo call cvar_set_info(wcd,n,v_is_group,v1,v2,typ) else - !write(*,*) 'STRUCT>',trim(pm_typ_as_string(wcd%context,typ)) + !write(*,*) 'STRUCT>',trim(pm_type_as_string(wcd%context,typ)) n=cvar_alloc_entry(wcd,v_is_basic,name,flags,typ) call add_to_typeset(wcd,typ) endif - case(pm_typ_is_array) + case(pm_type_is_array) if(iand(flags,v_is_param+v_is_result)/=0.and.& iand(flags,v_is_chan)==0) then nflags=ior(flags,v_is_array_par_dom) if(pm_tv_name(tv)/=sym_var) nflags=iand(nflags,not(v_is_ref)) tno=pm_tv_arg(tv,1) - if(iand(pm_typ_flags(wcd%context,tno),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(wcd%context,tno),pm_type_has_storage)/=0) then vec=cvar_alloc_entry(wcd,v_is_basic,pm_tv_arg(tv,3),& ior(flags,v_is_array_par_vect),tno) else vec=cvar_alloc(wcd,tno,flags,aname) endif tno=pm_tv_arg(tv,2) - if(iand(pm_typ_flags(wcd%context,tno),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(wcd%context,tno),pm_type_has_storage)/=0) then dom=cvar_alloc_entry(wcd,v_is_basic,name,& nflags,tno) else @@ -4958,9 +4958,9 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) n=cvar_alloc_entry(wcd,v_is_basic,name,ior(flags,v_is_farray),typ) endif call add_to_typeset(wcd,typ) - case(pm_typ_is_user) - n=cvar_alloc(wcd,pm_user_typ_body(wcd%context,typ),flags,aname) - case(pm_typ_is_tuple,pm_typ_is_vtuple) + case(pm_type_is_user) + n=cvar_alloc(wcd,pm_user_type_body(wcd%context,typ),flags,aname) + case(pm_type_is_tuple,pm_type_is_vtuple) m=pm_tv_numargs(tv) n=cvar_alloc_slots(wcd,3+m) v1=m @@ -4969,14 +4969,14 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) wcd%vinfo(n+i+2)=ptr(cvar_alloc(wcd,pm_tv_arg(tv,i),flags)) enddo call cvar_set_info(wcd,n,v_is_group,v1,v2,typ) - case(pm_typ_is_dref) + case(pm_type_is_dref) nflags=ior(iand(flags,not(v_is_shared+v_is_ref+v_is_vect)),& merge(0,v_is_in_dref,pm_tv_name(tv)==sym_pling)) i=pm_tv_flags(tv) n=cvar_alloc_slots(wcd,8) v1=5 v2=merge(v_is_shared_dref,v_is_dref,& - pm_typ_get_mode(wcd%context,pm_tv_arg(tv,3))>=sym_mirrored) + pm_type_get_mode(wcd%context,pm_tv_arg(tv,3))>=sym_mirrored) wcd%vinfo(n+3)=dptr(pm_tv_arg(tv,1),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,1),nflags)) wcd%vinfo(n+4)=dptr(pm_tv_arg(tv,2),ior(nflags,iand(flags,v_is_ref))) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,2),ior(nflags,v_is_ref))) @@ -4984,14 +4984,14 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) wcd%vinfo(n+6)=dptr(pm_tv_arg(tv,4),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,4),nflags)) wcd%vinfo(n+7)=dptr(pm_tv_arg(tv,5),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,5),nflags)) call cvar_set_info(wcd,n,v_is_group,v1,v2,typ) - case(pm_typ_is_poly) + case(pm_type_is_poly) n=cvar_alloc_entry(wcd,v_is_basic,name,ior(flags,v_is_poly),typ) - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_type) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_type) n=cvar_alloc_entry(wcd,v_is_group,0,v_is_storageless,typ) - case(pm_typ_is_value) + case(pm_type_is_value) n=cvar_alloc_entry(wcd,v_is_ctime_const,add_const(wcd,& - pm_typ_val(wcd%context,typ)),0,typ) - case(pm_typ_is_par_kind) + pm_type_val(wcd%context,typ)),0,typ) + case(pm_type_is_par_kind) k=pm_tv_name(tv) nflags=flags if(k>=sym_mirrored) nflags=ior(nflags,v_is_shared) @@ -5004,14 +5004,14 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) else n=cvar_alloc(wcd,pm_tv_arg(tv,1),nflags,name) endif - case(pm_typ_is_all) + case(pm_type_is_all) ! This just caters for _nhd variables n=cvar_alloc(wcd,pm_tv_arg(tv,1),flags,name) - case(pm_typ_is_vect) + case(pm_type_is_vect) n=cvar_alloc(wcd,pm_tv_arg(tv,1),ior(flags,v_is_vect),name) n=cvar_alloc_entry(wcd,v_is_vect_wrapped,n,0,pm_tv_arg(tv,1)) case default - write(*,*) 'CVAR ALLOC:', tk,trim(pm_typ_as_string(wcd%context,typ)) + write(*,*) 'CVAR ALLOC:', tk,trim(pm_type_as_string(wcd%context,typ)) call pm_panic('cvar_alloc') end select endif @@ -5056,11 +5056,11 @@ recursive subroutine add_to_typeset(wcd,typ,dim) integer:: tno,key(2),m integer:: i type(pm_ptr):: tv - tno=pm_typ_strip_to_basic(wcd%context,typ) + tno=pm_type_strip_to_basic(wcd%context,typ) tset=wcd%typeset if(tno>0.and.tno<=pm_string.and..not.present(dim)) return - if(.not.pm_typ_needs_storage(wcd%context,abs(tno))) return - if(pm_typ_kind(wcd%context,tno)==pm_typ_is_poly) tno=pm_pointer + if(.not.pm_type_needs_storage(wcd%context,abs(tno))) return + if(pm_type_kind(wcd%context,tno)==pm_type_is_poly) tno=pm_pointer key(1)=tno if(present(dim)) then key(2)=dim @@ -5068,8 +5068,8 @@ recursive subroutine add_to_typeset(wcd,typ,dim) key(2)=0 endif if(pm_ivect_lookup(wcd%context,tset,key,2)<=0) then - tv=pm_typ_vect(wcd%context,abs(tno)) - if(pm_tv_kind(tv)==pm_typ_is_array) then + tv=pm_type_vect(wcd%context,abs(tno)) + if(pm_tv_kind(tv)==pm_type_is_array) then call add_to_typeset(wcd,pm_tv_arg(tv,1),pm_tv_arg(tv,3)) endif do i=1,pm_tv_numargs(tv) @@ -5109,18 +5109,18 @@ function cvar_const(wcd,arg) result(slot1) integer:: slot1,slot2 integer:: tno,mode,tk type(pm_ptr):: tv - tno=pm_typ_strip_mode(wcd%context,cnode_get_num(arg,cnode_args+1),mode) + tno=pm_type_strip_mode(wcd%context,cnode_get_num(arg,cnode_args+1),mode) if(tno<=pm_null) then slot1=cvar_alloc_entry(wcd,v_is_group,0,v_is_storageless,tno) else - tv=pm_typ_vect(wcd%context,tno) + tv=pm_type_vect(wcd%context,tno) tk=pm_tv_kind(tv) - if(tk==pm_typ_is_single_name.or.tk==pm_typ_is_proc) then + if(tk==pm_type_is_single_name.or.tk==pm_type_is_proc) then slot1=cvar_alloc_entry(wcd,v_is_group,0,v_is_storageless,tno) else slot2=add_const(wcd,cnode_arg(arg,1)) slot1=cvar_alloc_entry(wcd,& - merge(v_is_ctime_const,v_is_const,pm_tv_kind(tv)==pm_typ_is_value),& + merge(v_is_ctime_const,v_is_const,pm_tv_kind(tv)==pm_type_is_value),& slot2,0,tno) endif endif @@ -5222,7 +5222,7 @@ function cvar_alloc_elem(wcd,parent,elem) result(n) integer,intent(in):: parent,elem integer:: n type(pm_ptr):: tv - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) n=cvar_alloc_entry(wcd,merge(v_is_unit_elem,v_is_elem,pm_tv_numargs(tv)==1.and..false.),& parent,elem,pm_tv_arg(tv,elem)) end function cvar_alloc_elem @@ -5263,9 +5263,9 @@ subroutine cvar_set_elem(wcd,n,parent,elem) call pm_panic('cvar_set_elem') endif endif - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) -!!$ write(*,*) cvar_type(wcd,parent),'>>',elem,';',trim(pm_typ_as_string(wcd%context,cvar_type(wcd,parent))),& -!!$ ';',trim(pm_typ_as_string(wcd%context,cvar_type(wcd,n))) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) +!!$ write(*,*) cvar_type(wcd,parent),'>>',elem,';',trim(pm_type_as_string(wcd%context,cvar_type(wcd,parent))),& +!!$ ';',trim(pm_type_as_string(wcd%context,cvar_type(wcd,n))) call cvar_set_info(wcd,n,merge(v_is_unit_elem,v_is_elem,pm_tv_numargs(tv)==1.and..false.),& parent,elem,pm_tv_arg(tv,elem)) end subroutine cvar_set_elem @@ -5306,7 +5306,7 @@ subroutine cvar_set_info(wcd,n,kind,v1,v2,tno) if(kind==v_is_alias.and.v1==0) then call pm_panic('Alias to nothing...') endif - if(tno/=0) junk=pm_typ_name(wcd%context,tno) + if(tno/=0) junk=pm_type_name(wcd%context,tno) endif wcd%vinfo(n)=v1*cvar_flag_mult+kind wcd%vinfo(n+1)=v2*cvar_flag_mult @@ -5893,7 +5893,7 @@ subroutine dump_single_cvar(context,iunit,n,array) typ=array(n+2)/cvar_flag_mult if(kind==v_is_group) then write(iunit,'(i6,1x,a5,1x,a7,1x,a,1x,10i6)') n,v_names(kind),& - v_groups(v2),trim(pm_typ_as_string(context,typ)),& + v_groups(v2),trim(pm_type_as_string(context,typ)),& (array(n+2+i)/cvar_flag_mult,i=1,min(10,v1)) n=n+v1+3 elseif(kind==v_is_basic) then @@ -5911,18 +5911,18 @@ subroutine dump_single_cvar(context,iunit,n,array) if(iand(v2,v_is_array_par_vect)==0) then write(iunit,'(i6,1x,a5,1x,a,1x,i6,a,1x,a)') n,v_names(kind),& trim(pm_name_as_string(context,v1)),& - typ,trim(pm_typ_as_string(context,typ)),flag_str + typ,trim(pm_type_as_string(context,typ)),flag_str else write(iunit,'(i6,1x,a5,1x,a,1x,i6,a,1x,a)') n,v_names(kind),& - trim(pm_typ_as_string(context,v1)),& - typ,trim(pm_typ_as_string(context,typ)),flag_str + trim(pm_type_as_string(context,v1)),& + typ,trim(pm_type_as_string(context,typ)),flag_str endif n=n+3 elseif(kind==0) then n=n+1 else write(iunit,'(i6,1x,a5,i6,i6,1x,a)') n,v_names(kind),& - v1,v2,trim(pm_typ_as_string(context,typ)) + v1,v2,trim(pm_type_as_string(context,typ)) n=n+3 endif end subroutine dump_single_cvar From 50a5739ac7e74aaa72ca96d27b0c78f24e490264 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 25 Apr 2024 09:30:44 +0100 Subject: [PATCH 03/36] Add if scope parameters --- pm/Makefile | 24 +- pmc/Makefile | 15 +- src/ast.f90 | 434 +++ src/cfortran.save.f90 | 6159 --------------------------------------- src/cmain.f90 | 190 -- src/cnodes.f90 | 811 ++++++ src/codegen.f90 | 1130 ++----- src/deadcode.f90 | 174 ++ src/infer.f90 | 13 + src/lib.f90 | 2 + src/parser.f90 | 393 +-- src/sysdefs_old_nhd.f90 | 5597 ----------------------------------- src/wcoder.f90 | 6 +- 13 files changed, 1712 insertions(+), 13236 deletions(-) create mode 100644 src/ast.f90 delete mode 100644 src/cfortran.save.f90 delete mode 100755 src/cmain.f90 create mode 100644 src/cnodes.f90 create mode 100644 src/deadcode.f90 delete mode 100755 src/sysdefs_old_nhd.f90 diff --git a/pm/Makefile b/pm/Makefile index 1e3f3f5..0143700 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -24,12 +24,12 @@ # THE SOFTWARE. FC=gfortran PC=mpifort -FFLAGS= -g -I../src -fbounds-check -fcheck=mem # -Wall +FFLAGS= -g -I../src -fbounds-check -fcheck=mem # -Wall PFLAGS= -g -I../src -fbounds-check -fcheck=mem -PMCODE= sysdep.o kinds.o pcomp.o memory.o hash.o opts.o lib.o symbol.o types.o parser.o linker.o vmdefs.o sysdefs.o codegen.o infer.o wcoder.o array.o parlib.o vm.o main.o +PMCODE= sysdep.o kinds.o pcomp.o memory.o hash.o opts.o lib.o symbol.o types.o ast.o parser.o linker.o vmdefs.o sysdefs.o cnodes.o codegen.o infer.o wcoder.o array.o parlib.o vm.o main.o -PMCODE2= ../config/sysdep.f90 ../src/kinds.f90 ../src/pcomp.f90 ../src/memory.f90 ../src/hash.f90 ../src/opts.f90 ../src/lib.f90 ../src/symbol.f90 ../src/types.f90 ../src/parser.f90 ../src/linker.f90 ../src/vmdefs.f90 ../src/sysdefs.f90 ../src/codegen.f90 ../src/infer.f90 ../src/wcoder.f90 ../src/array.f90 ../src/parlib.f90 ../src/vm.f90 ../src/main.f90 +PMCODE2= ../config/sysdep.f90 ../src/kinds.f90 ../src/pcomp.f90 ../src/memory.f90 ../src/hash.f90 ../src/opts.f90 ../src/lib.f90 ../src/symbol.f90 ../src/types.f90 ../src/ast.f90 ../src/parser.f90 ../src/linker.f90 ../src/vmdefs.f90 ../src/sysdefs.f90 ../src/cnodes.f90 ../src/codegen.f90 ../src/infer.f90 ../src/wcoder.f90 ../src/array.f90 ../src/parlib.f90 ../src/vm.f90 ../src/main.f90 @@ -71,7 +71,10 @@ types.o : ../src/types.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o vmdefs.o : ../src/vmdefs.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -parser.o : ../src/parser.f90 types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +ast.o : ../src/ast.f90 types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o + $(FC) $(FFLAGS) -c $< + +parser.o : ../src/parser.f90 ast.o types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< array.o : ../src/array.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o @@ -80,19 +83,22 @@ array.o : ../src/array.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o parlib.o : ../src/parlib.f90 array.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(PC) $(PFLAGS) -c $< -linker.o : ../src/linker.f90 parser.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +linker.o : ../src/linker.f90 ast.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o + $(FC) $(FFLAGS) -c $< + +sysdefs.o : ../src/sysdefs.f90 vmdefs.o ast.o parser.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -sysdefs.o : ../src/sysdefs.f90 vmdefs.o parser.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +cnodes.o : ../src/cnodes.f90 ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -codegen.o : ../src/codegen.f90 parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -infer.o : ../src/infer.f90 codegen.o parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +infer.o : ../src/infer.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -wcoder.o : ../src/wcoder.f90 array.o infer.o codegen.o parser.o symbol.o sysdefs.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +wcoder.o : ../src/wcoder.f90 array.o infer.o cnodes.o ast.o symbol.o sysdefs.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< vm.o : ../src/vm.f90 parlib.o array.o sysdefs.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o diff --git a/pmc/Makefile b/pmc/Makefile index 3349517..7784a3f 100755 --- a/pmc/Makefile +++ b/pmc/Makefile @@ -27,7 +27,7 @@ PC=mpifort FFLAGS= -I../src/ -g -fbounds-check -fcheck=mem # -Wall PFLAGS= -I../src/ -g -fbounds-check -fcheck=mem -PMCODE= sysdep.o scomp.o kinds.o memory.o hash.o opts.o lib.o types.o symbol.o vmdefs.o parser.o linker.o sysdefs.o codegen.o infer.o wcoder.o optimise.o cfortran.o main.o +PMCODE= sysdep.o scomp.o kinds.o memory.o hash.o opts.o lib.o types.o symbol.o vmdefs.o ast.o parser.o linker.o sysdefs.o cnodes.o codegen.o infer.o wcoder.o optimise.o cfortran.o main.o all : pmc @@ -68,8 +68,10 @@ lib.o : ../src/lib.f90 symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o vmdefs.o : ../src/vmdefs.f90 lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< +ast.o : ../src/ast.f90 vmdefs.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o + $(FC) $(FFLAGS) -c $< -parser.o : ../src/parser.f90 vmdefs.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +parser.o : ../src/parser.f90 ast.o vmdefs.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< types.o : ../src/types.f90 lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o @@ -81,13 +83,16 @@ linker.o : ../src/linker.f90 parser.o lib.o symbol.o opts.o hash.o memory.o kin sysdefs.o : ../src/sysdefs.f90 vmdefs.o parser.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< -codegen.o : ../src/codegen.f90 parser.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +cnodes.o : ../src/cnodes.f90 parser.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o + $(FC) $(FFLAGS) -c $< + +codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< -infer.o : ../src/infer.f90 codegen.o parser.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< -wcoder.o : ../src/wcoder.f90 infer.o codegen.o parser.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +wcoder.o : ../src/wcoder.f90 infer.o cnodes.o ast.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< optimise.o : ../src/optimise.f90 ../src/rtime.inc wcoder.o infer.o codegen.o linker.o parser.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o diff --git a/src/ast.f90 b/src/ast.f90 new file mode 100644 index 0000000..33ec223 --- /dev/null +++ b/src/ast.f90 @@ -0,0 +1,434 @@ +! +! PM (Parallel Models) Programming Language +! +! Released under the MIT License (MIT) +! +! Copyright (c) Tim Bellerby, 2024 +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. + +! Definitions for abstract syntax tree + +module pm_ast + use pm_sysdep + use pm_compbase + use pm_kinds + use pm_memory + use pm_lib + use pm_options + use pm_hash + use pm_symbol + use pm_vmdefs + use pm_types + + ! Offsets into module objects + integer,parameter:: modl_name=1 + integer,parameter:: modl_link=2 + integer,parameter:: modl_last=3 + integer,parameter:: modl_stmts=4 + integer,parameter:: modl_include=5 + integer,parameter:: modl_proc=6 + integer,parameter:: modl_type=7 + integer,parameter:: modl_param=8 + integer,parameter:: modl_local=3 + + ! Offsets into parser node objects of various kinds + integer,parameter:: node_magic=0 + integer,parameter:: node_symbol=1 + integer,parameter:: node_modl=2 + integer,parameter:: node_lineno=3 + integer,parameter:: node_charno=4 + integer,parameter:: node_args=5 + + ! Type parse nodes + integer,parameter:: typ_name=node_args + integer,parameter:: typ_number=node_args+1 + integer,parameter:: typ_module=node_args+2 + integer,parameter:: typ_params=node_args+3 + integer,parameter:: typ_constraints=node_args+4 + integer,parameter:: typ_link=node_args+5 + integer,parameter:: typ_ins=node_args+6 + integer,parameter:: typ_includes=node_args+7 + integer,parameter:: typ_num_args=8 + + ! Proc parse nodes + integer,parameter:: proc_name=node_args + integer,parameter:: proc_link=node_args+1 + integer,parameter:: proc_module=node_args+2 + integer,parameter:: proc_flags=node_args+3 + integer,parameter:: proc_params=node_args+4 + integer,parameter:: proc_keys=node_args+5 + integer,parameter:: proc_amplocs=node_args+6 + integer,parameter:: proc_coded_params=node_args+7 + integer,parameter:: proc_coded_results=node_args+8 + integer,parameter:: proc_coded_type=node_args+9 + integer,parameter:: proc_numret=node_args+10 + integer,parameter:: proc_result_types=node_args+11 + + ! Alternative final sections for 'proc' parse nodes + + ! - user functions + integer,parameter:: proc_reduce=node_args+12 + integer,parameter:: proc_check=node_args+13 + integer,parameter:: proc_result=node_args+14 + integer,parameter:: proc_stmts=node_args+15 + integer,parameter:: proc_code_tree=node_args+16 + integer,parameter:: proc_num_args=17 + + ! - built in functions + integer,parameter:: proc_retas=node_args+12 + integer,parameter:: proc_opcode=node_args+13 + integer,parameter:: proc_opcode2=node_args+14 + integer,parameter:: proc_data=node_args+15 + integer,parameter:: proc_coded_builtin=node_args+16 + integer,parameter:: sysproc_num_args=17 + + ! Values for flags (other values defined in sysdefs) + integer,parameter:: proc_is_comm=1 + integer,parameter:: proc_run_complete=2 + integer,parameter:: proc_run_local=4 + integer,parameter:: proc_run_shared=8 + integer,parameter:: proc_run_always=16 + integer,parameter:: proc_inline=32 + integer,parameter:: proc_no_inline=64 + integer,parameter:: proc_is_open=128 + integer,parameter:: proc_is_each_proc=256 + integer,parameter:: proc_is_cond=512 + integer,parameter:: proc_is_uncond=1024 + integer,parameter:: proc_is_abstract=2048 + + ! Corresponding flags in proc calls (must be same as for proc_is) + integer,parameter:: call_is_comm=1 + integer,parameter:: call_ignore_rules=256 + +contains + + !====================================================== + ! Check that a node is valid + !====================================================== + subroutine check_node(node) + type(pm_ptr),intent(in):: node + if(pm_fast_vkind(node)==pm_pointer) then + if(node%data%ptr(node%offset)%offset/=9876) then + call pm_panic('Bad parse node') + endif + endif + contains + include 'fvkind.inc' + end subroutine check_node + + !======================================================= + ! Check that a node is valid and not a tiny int or value + !======================================================= + subroutine check_ptr_node(node) + type(pm_ptr),intent(in):: node + if(pm_fast_vkind(node)==pm_pointer) then + if(node%data%ptr(node%offset)%offset/=9876) then + call pm_panic('Bad parse node') + endif + else + call pm_panic('not ptr parser node') + endif + contains + include 'fvkind.inc' + end subroutine check_ptr_node + + !====================================================== + ! Return symbol associated with a node + !====================================================== + function node_sym(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_fast_vkind(node)/=pm_pointer) then + n=0 + else + if(pm_debug_checks) call check_node(node) + n=node%data%ptr(node%offset+node_symbol)%offset + endif + contains + include 'fvkind.inc' + end function node_sym + + !====================================================== + ! Number of arguments in a node + !====================================================== + function node_numargs(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_fast_vkind(node)/=pm_pointer) then + n=0 + else + if(pm_debug_checks) call check_node(node) + n=pm_fast_esize(node)-node_args+1 + endif + contains + include 'fesize.inc' + include 'fvkind.inc' + end function node_numargs + + !====================================================== + ! Return n-th argument of a node + !====================================================== + function node_arg(node,n) result(p) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.node_args+n-1>pm_fast_esize(node)) & + call pm_panic('node_arg - n out of range') + endif + p=node%data%ptr(node%offset+node_args+n-1) + contains + include 'fesize.inc' + end function node_arg + + !====================================================== + ! Return n-th argument of a node as a number + ! (that argument should be tiny-int) + !====================================================== + function node_num_arg(node,n) result(num) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + integer:: num + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.node_args+n-1>pm_fast_esize(node)) & + call pm_panic('node_arg - n out of range') + endif + p=node%data%ptr(node%offset+node_args+n-1) + num=p%offset + contains + include 'fesize.inc' + end function node_num_arg + + !====================================================== + ! Return n-th slot in a node (not the same as argument) + !====================================================== + function node_get(node,n) result(p) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.n>pm_fast_esize(node)) & + call pm_panic('node_get - n out of range') + endif + p=node%data%ptr(node%offset+n) + contains + include 'fesize.inc' + end function node_get + + !====================================================== + ! Return n-th slot in a node (not the same as argument) + ! as a number (must be tiny int) + !====================================================== + function node_get_num(node,n) result(num) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + integer:: num + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.n>pm_fast_esize(node)) & + call pm_panic('node_get_num - n out of range') + endif + p=node%data%ptr(node%offset+n) + num=p%offset + contains + include 'fesize.inc' + end function node_get_num + + !====================================================== + ! Set n-th slot in a node (not the same as argument) + ! to a number (tiny int) + !====================================================== + subroutine node_set_num(node,n,num) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + integer,intent(in):: num + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.n>pm_fast_esize(node)) & + call pm_panic('node_get_num - n out of range') + endif + node%data%ptr(node%offset+n)%offset=num + contains + include 'fesize.inc' + end subroutine node_set_num + + !====================================================== + ! Get the line number associated with a node + !====================================================== + function node_get_lineno(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_debug_checks) & + call check_ptr_node(node) + n=node%data%ptr(node%offset+node_lineno)%offset + end function node_get_lineno + + !====================================================== + ! Get the character position (in source) associated + ! with a node + !====================================================== + function node_get_charno(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_debug_checks) & + call check_ptr_node(node) + n=node%data%ptr(node%offset+node_charno)%offset + end function node_get_charno + + !====================================================== + ! Get the module object associated with a node + !====================================================== + function node_get_modl(node) result(modl) + type(pm_ptr),intent(in):: node + type(pm_ptr):: modl + if(pm_debug_checks) & + call check_ptr_node(node) + modl=node%data%ptr(node%offset+node_modl) + contains + include 'fvkind.inc' + end function node_get_modl + + !====================================================== + ! Get the module name associated with a node + !====================================================== + function node_get_modl_name(node) result(name) + type(pm_ptr),intent(in):: node + integer:: name + type(pm_ptr):: modl + if(pm_debug_checks) & + call check_ptr_node(node) + modl=node_get_modl(node) + name=modl%data%ptr(modl%offset+modl_name)%offset + end function node_get_modl_name + + + !====================================================== + ! Dump a module (debugging) + !====================================================== + subroutine dump_module(context,iunit,ptr) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: ptr + character(len=100):: str + character(len=7),dimension(modl_include:modl_param):: dnames = & + (/ & + 'include',& + 'proc ',& + 'type ',& + 'param '/) + integer:: i,j,k,m + type(pm_ptr):: keys,vals,p + call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) + write(iunit,*) 'Module: ',trim(str) + write(iunit,*) 'Stmts:' + call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+modl_stmts),2) + do k=0,modl_local,modl_local + if(k==modl_local) then + write(iunit,*) 'Local:' + m=modl_proc + else + ! m=modl_include + m=modl_proc + endif + do j=m,modl_param + write(iunit,*) dnames(j),& + marked(ptr%data%ptr(ptr%offset+j+k)),'::' + keys=pm_dict_keys(context,ptr%data%ptr(ptr%offset+j+k)) + vals=pm_dict_vals(context,ptr%data%ptr(ptr%offset+j+k)) + write(iunit,*) marked(keys),marked(vals) + do i=1,pm_dict_size(context,ptr%data%ptr(ptr%offset+j+k)) + call pm_name_string(context,& + int(keys%data%ptr(keys%offset+i-1)%offset),str) + write(iunit,*) ' ',trim(str),'::' + write(iunit,*) marked(vals%data%ptr(vals%offset+i-1)) + p=vals%data%ptr(vals%offset+i-1) + call dump_parse_tree(context,iunit,& + p%data%ptr(p%offset),2) + enddo + enddo + enddo + end subroutine dump_module + + !====================================================== + ! Dump a parser tree (debugging) + !====================================================== + recursive subroutine dump_parse_tree(context,iunit,ptr,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: ptr + integer,intent(in):: depth + integer:: i, sym + character(len=80),parameter:: spaces = ' ' + character(len=100):: str + if(depth>30) then + write(iunit,*) spaces(:depth*2),'>>>' + return + endif + if(pm_fast_vkind(ptr)==pm_pointer) then + if(ptr%data%ptr(ptr%offset)%offset/=9876) then + if(ptr%data%ptr(ptr%offset)%offset==9875) then + write(iunit,*) spaces(1:depth*2),'REUSED NODE',& + ptr%offset,ptr%data%hash,ptr%data%esize + else + write(iunit,*) spaces(1:depth*2),'INVALID NODE' + return + endif + endif + sym=ptr%data%ptr(ptr%offset+1)%offset + if(sym>0.and.sym<=num_syshook) then + write(iunit,*) spaces(1:depth*2),sym_names(sym),ptr%data%esize,& + 'line',node_get_lineno(ptr),& + 'Marked:',marked(ptr),& + ptr%data%hash,ptr%offset,ptr%offset+ptr%data%esize + else if(sym==0) then + call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) + write(iunit,*) spaces(1:depth*2),'Module: ',trim(str) + return + else + write(iunit,*) spaces(1:depth*2),'???',trim(pm_name_as_string(context,sym)) + return + endif + do i=node_args,ptr%data%esize + call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+i),& + depth+1) + enddo + else if(pm_fast_isnull(ptr)) then + write(iunit,*) spaces(1:depth*2),'NULL' + else if(pm_fast_isname(ptr)) then + call pm_name_string(context,int(ptr%offset),str) + write(iunit,*) spaces(1:depth*2),'Name:',trim(str) + else if(pm_fast_istiny(ptr)) then + write(iunit,*) spaces(1:depth*2),'Tiny number:',ptr%offset + else + call pm_dump_tree(context,iunit,ptr,depth) + endif + contains + include 'fvkind.inc' + include 'fisnull.inc' + include 'fisname.inc' + include 'fistiny.inc' + end subroutine dump_parse_tree + +end module pm_ast diff --git a/src/cfortran.save.f90 b/src/cfortran.save.f90 deleted file mode 100644 index 5584e58..0000000 --- a/src/cfortran.save.f90 +++ /dev/null @@ -1,6159 +0,0 @@ -! -! PM (Parallel Models) Programming Language -! -! Released under the MIT License (MIT) -! -! Copyright (c) Tim Bellerby, 2023 -! -! Permission is hereby granted, free of charge, to any person obtaining a copy -! of this software and associated documentation files (the "Software"), to deal -! in the Software without restriction, including without limitation the rights -! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -! copies of the Software, and to permit persons to whom the Software is -! furnished to do so, subject to the following conditions: -! -! The above copyright notice and this permission notice shall be included in -! all copies or substantial portions of the Software. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -! THE SOFTWARE. - -! Generate FORTRAN code from wordcodes - -module pm_backend - - use pm_kinds - use pm_memory - use pm_types - use pm_vmdefs - use pm_hash - use pm_lib - use pm_wcode - - implicit none - - logical,parameter:: debug_g=.false. - - ! Various limits - integer,parameter:: ftn_max_line=130 - integer,parameter:: ftn_max_name=31 - integer,parameter:: max_vars=2**15-1 - integer,parameter:: max_levels=256 - integer,parameter:: max_loop_stack=10*1024 - - ! Variable descriptor - type gvar - integer:: tno ! Type - integer:: flags ! Flags from previous stage - integer:: gflags ! Flags applied in this stage - integer:: state ! State engine (determines if needs to be stored as vector) - integer:: start ! First instruction point var is used - integer:: finish ! Last instruction point var is used - integer:: lthis ! Parallel context - integer:: link ! Linked list of variables in creation order - integer:: elink ! Linked list of variables in destruction order - integer:: index ! Vector to store this variable (may be shared) - integer:: free ! List of variables free for reuse (*not unused records*) - integer:: oindex ! Index of variable in output from wordcode generator - integer:: outer_lthis ! Outermost parallel context in which variable is referenced - logical:: finish_on_assign - ! Last statement using this variable is assignment to another variable - integer:: name ! PM name of variable - end type gvar - - ! Variable states for identifying those - ! that need storing in local arrays - ! in concurrent code (employed by small - ! state machine) - integer,parameter:: var_state_unused=0 - integer,parameter:: var_state_open=1 - integer,parameter:: var_state_used=2 - integer,parameter:: var_state_used_before=3 - integer,parameter:: var_state_crossing=4 - integer,parameter:: var_state_closed=5 - - ! Local flags for variables - integer,parameter:: var_is_recycled=1 - integer,parameter:: var_is_async=2 - integer,parameter:: var_is_else_disabled=4 - integer,parameter:: var_is_comm_op_par=8 - integer,parameter:: var_is_used=16 - integer,parameter:: var_is_reused=32 - integer,parameter:: var_is_stacked_ve=64 - - ! Loop modes - integer,parameter:: loop_is_none=0 - integer,parameter:: loop_is_contig=1 - integer,parameter:: loop_is_nested=2 - - ! Loop parameters - integer,parameter:: loop_start=1 - integer,parameter:: loop_end=2 - integer,parameter:: loop_step=3 - integer,parameter:: loop_size=4 - integer,parameter:: loop_block=5 - - ! Parallel context - type gloop - integer:: varlist - integer:: evarlist - integer:: defer_free - integer:: idx - integer:: free(2,pm_int:pm_string) - integer:: nloops - integer:: loop_mode - integer:: loop_par - logical:: loop_active - end type gloop - - ! Kinds of name (used in Fortran name mangler) - integer,parameter:: name_of_var=1 - integer,parameter:: name_of_elem=2 - integer,parameter:: name_of_proc=3 - integer,parameter:: name_of_type=4 - - ! Current state of FORTRAN code generator - type gen_state - - type(pm_context),pointer:: context - - ! Alloc procedures - type(pm_ptr):: procs - - ! Current proc - type(pm_ptr):: fn - integer:: taints - - ! Wordcodes for current proc - integer,dimension(:),pointer:: codes - integer,dimension(:),pointer:: vars - - ! Variables - integer:: nvars,index - integer,dimension(:),allocatable:: varindex - type(gvar),dimension(:),allocatable:: vardata - - ! Parallel loop frames - type(gloop),dimension(0:max_loop_stack):: lstack - integer:: lthis,ltop,last_ve - integer:: lalt - - ! Typesets - type(pm_ptr):: poly_cache,packables,mpi_types,mpi_root_types - type(pm_reg),pointer:: reg - - ! Mangled names - type(pm_ptr):: name_cache(name_of_var:name_of_type) - - ! Does current loop contain shared operations? - logical:: loop_contains_shared - - ! Fortran code output - character(len=ftn_max_line):: linebuffer - integer:: n,outunit - integer:: line_breaks - - end type gen_state - - ! Control how an argument is converted - integer,parameter:: arg_no_index=1 - integer,parameter:: arg_ix_index=2 - integer,parameter:: arg_comm_arg=4 - integer,parameter:: arg_wrapped=8 - integer,parameter:: arg_chan=16 - - ! Type of pack routine (for g_add_packable) - integer,parameter:: pack_scalar=0 - integer,parameter:: pack_vect=1 - integer,parameter:: pack_array_vect=2 - integer,parameter:: pack_vect_disp=3 - integer,parameter:: pack_array_vect_disp=4 - integer,parameter:: unpack_vect=5 - integer,parameter:: unpack_vect_disp=6 - - ! Modes of parameter passed to MPI comm operation - integer,parameter:: mode_array=0 - integer,parameter:: mode_vect=1 - integer,parameter:: mode_array_vect=2 - -contains - - !=========================================== - ! Generate Fortran code for program - !=========================================== - subroutine gen_prog(context,p,poly_cache,typeset,iunit) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: p,poly_cache,typeset - integer,intent(in):: iunit - type(gen_state),target:: g - type(pm_ptr):: key - integer:: i - integer:: tno - - ! Set up code generator state - g%context=>context - g%reg=>pm_register(context,'gen_prog',& - g%procs,g%poly_cache,g%packables,g%mpi_types,g%mpi_root_types) - g%procs=p - g%poly_cache=poly_cache - g%packables=pm_set_new(context,32_pm_ln) - g%mpi_types=pm_set_new(context,32_pm_ln) - g%mpi_root_types=pm_set_new(context,32_pm_ln) - g%outunit=iunit - g%line_breaks=0 - g%n=0 - - ! Output preamble (including runtime library) - call out_line_noindent(g,'PROGRAM PM') - i=iunit - include 'rtime.inc' - - ! Tidy up - call out_line_noindent(g,'END PROGRAM PM') - call pm_delete_register(context,g%reg) - - contains - - include 'fesize.inc' - - ! Generate procedures - subroutine gen_procs - integer(pm_ln):: i - - ! Generate code for each procedure - do i=1,pm_dict_size(context,p) - if(debug_g) write(*,*) 'OUTING PROC>',i-1 - call gen_proc(g,pm_dict_val(context,p,i),int(i-1)) - enddo - - ! Generate procedures to pack and unpack types - ! to a communications buffer - call gen_packables(g) - - ! Generate procedure to create required MPI types - call gen_mpi_types(g) - end subroutine gen_procs - - ! Output type definitions (called from rtime.inc) - subroutine out_types - integer:: i - type(pm_ptr):: keys,key - call out_new_line(g) - call out_type_defs(g,typeset) - call out_new_line(g) - end subroutine out_types - - end subroutine gen_prog - - - !=========================================== - ! Generate code for a single procedure - !=========================================== - subroutine gen_proc(g,p,no) - type(gen_state):: g - type(pm_ptr),intent(in)::p - integer,intent(in):: no - integer:: i,n,rvar,pvar,vevar,name - type(pm_ptr)::q,taint,keys - logical:: iscomm - - ! Get wordcodes & meta-info for this function - g%fn=p - q=p%data%ptr(p%offset) - rvar=q%data%i(q%offset) - pvar=q%data%i(q%offset+1) - name=q%data%i(q%offset+2) - vevar=q%data%i(q%offset+3) - g%codes=>q%data%i(q%offset+4:q%offset+pm_fast_esize(q)) - taint=p%data%ptr(p%offset+2) - keys=p%data%ptr(p%offset+3) - g%taints=taint%offset - iscomm=iand(int(taint%offset),proc_is_comm)/=0 - - ! Output spacing / comment - call out_new_line(g) - call out_line_noindent(g,' !'//& - trim(pm_name_as_string(g%context,name))) - if(debug_g) then - write(*,*) 'OUT START> ',& - trim(pm_name_as_string(g%context,q%data%i(q%offset+2))) - endif - - ! Set up variable data tables - q=p%data%ptr(p%offset+1) - g%vars=>q%data%i(q%offset:q%offset+pm_fast_esize(q)) - n=1+pm_fast_esize(q) - allocate(g%varindex(n)) - allocate(g%vardata(n/2)) - g%nvars=0 - g%varindex(1:n)=0 - - ! Output procedure header - if(iand(int(taint%offset),proc_is_recursive)/=0) & - call out_str(g,'RECURSIVE ') - if(iand(int(taint%offset),proc_is_impure)==0) & - call out_str(g,'PURE ') - call out_str(g,'SUBROUTINE PM__P') - call out_idx(g,no) - if(pm_opts%ftn_name_procs.and.no>0) then - call out_ftn_name(g,name) - endif - - ! Phase I - analyse variable use to determine variable lifetimes - ! and which variables need to be - ! stored as vectors - ! Also output necessary variable definition lines here - call init_g - g%ltop=-1 - call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none - if(vevar/=-1) then - call use_var(g,vevar) - call cross_var(g,vevar) - endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call use_var(g,keys%data%i(keys%offset+i)) - enddo - endif - if(pvar/=-1) call use_var(g,pvar) - if(size(g%codes)>0) call gen_var_block(g,comp_op_start) - if(rvar/=-1) call use_var(g,rvar) - - ! Phase II - analyse variable lifetimes to merge variables - do i=0,g%ltop - g%lthis=i - call sort_var_list(g) - call alloc_var_list(g) - enddo - - ! Phase III - output necessary definition lines - call out_char(g,'(') - if(iscomm) then - call out_str(g,'N1,') - if(vevar>0) then - call out_param(g,vevar) - call out_char(g,',') - endif - endif - if(rvar/=-1) then - call out_param(g,rvar) - endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call out_param(g,keys%data%i(keys%offset+i)) - enddo - endif - if(pvar/=-1) then - call out_param(g,pvar) - endif - call out_close(g) - call out_new_line(g) - if(iscomm) then - call out_line(g,'INTEGER(PM__LN),INTENT(IN):: N1') - endif - do i=1,g%nvars - call out_var_def(g,i,iscomm) - enddo - - ! Phase IV - output code for the body of the procedure - call init_g - if(size(g%codes)>0) then - call gen_block(g,comp_op_start) - call gen_if_nest(g,g%last_ve,0) - call gen_close_loops(g) - endif - call out_str_noindent(g,' END SUBROUTINE PM__P') - call out_idx(g,no) - if(pm_opts%ftn_name_procs.and.no>0) then - call out_ftn_name(g,name) - endif - call out_new_line(g) - - ! Tidy up - deallocate(g%varindex) - deallocate(g%vardata) - if(debug_g) then - write(*,*) 'OUT DONE> ',& - trim(pm_name_as_string(g%context,& - q%data%i(q%offset+2))) - endif - - contains - include 'fesize.inc' - include 'fisnull.inc' - subroutine init_g - g%lthis=0 - g%ltop=0 - g%lalt=-1 - g%loop_contains_shared=.false. - end subroutine init_g - end subroutine gen_proc - - function g_procname(g,n) result(name) - type(gen_state):: g - integer,intent(in):: n - integer:: name - type(pm_ptr):: p,q - p=pm_dict_val(g%context,g%procs,int(n+1,pm_ln)) - q=p%data%ptr(p%offset) - name=q%data%i(q%offset+2) - end function g_procname - - !************************************************ - ! PHASE I - VARIABLE ASSIGNMENT - !************************************************ - - !=========================================== - ! Variable assignment phase for a code block - !=========================================== - recursive subroutine gen_var_block(g,loc) - type(gen_state):: g - integer,intent(in):: loc - integer:: l - if(debug_g) write(*,*) 'VAR BLOCK>' - l=loc - do while(l>0) - if(debug_g) write(*,*) 'DO VAR>',l - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,l) - l=g%codes(l) - if(debug_g) write(*,*) 'NEXT VAR',l - enddo - if(debug_g) write(*,*) 'END VAR BLOCK>' - end subroutine gen_var_block - - !================================================== - ! Variable assignment phase for a single operation - !================================================== - recursive subroutine gen_var_op(g,l) - type(gen_state):: g - integer,intent(in):: l - integer:: opcode,opcode2,n,arg - integer:: i,j,a,save_lthis,ll,var1,idx1 - logical:: save_loop_contains_shared - if(pm_debug_level>0) then - if(l>size(g%codes)) then - write(*,*) 'l=',l,size(g%codes) - call pm_panic('gen_var_op bad l') - endif - endif - opcode=g%codes(l+comp_op_opcode) - opcode2=g%codes(l+comp_op_opcode2) - n=g%codes(l+comp_op_nargs) - a=l+comp_op_arg0 - - if(debug_g) then - write(*,*) 'l=',l,n,op_names(opcode) - write(*,*) 'VAR OP> ',g%lstack(g%lthis)%idx,l,op_names(opcode),n,& - '>>',g%codes(l:l+comp_op_arg0+n-1) - endif - - select case(opcode) - case(op_if,op_if_shared,op_if_restart) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - case(op_if_shared_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - case(op_over,op_skip_empty) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call cross_all_vars(g) - case(op_head_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - case(op_loop) - save_loop_contains_shared=g%loop_contains_shared - g%loop_contains_shared=.false. - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - if(g%loop_contains_shared) then - g%codes(l+comp_op_opcode2)=ior(g%codes(l+comp_op_opcode2),2) - endif - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_loop,op_comm_loop_par) - save_loop_contains_shared=g%loop_contains_shared - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - call cross_all_vars(g) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_proc) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_inline_shared) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_shared_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_block) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+2)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_call,op_dref,op_wrap) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - call use_var(g,g%codes(a+i)) - enddo - case(op_comm_inline) !!! Obsolete? - call cross_all_vars(g) - case(op_sync) - call cross_all_vars(g) - case(op_broadcast_val,& - op_sync_mess,op_break_loop,& - op_read_file_tile,op_write_file_tile,op_broadcast,& - op_broadcast_shared,op_nested_loop,& - op_blocked_loop,op_isend_offset,op_irecv_offset,& - op_recv_offset,op_recv_offset_resend,op_isend_reply,& - op_recv_reply,op_isend_req,op_isend_assn,op_active,op_get_size) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_remote_send_call,op_collect_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=6,n-1 !!! Dont use or cross outputs - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - save_lthis=g%lthis - call g_new_frame(g) - call use_var(g,g%codes(a+4)) - call cross_var(g,g%codes(a+4)) - call use_var(g,g%codes(a+5)) - call cross_var(g,g%codes(a+5)) - call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis - call gen_var_block(g,g%codes(a+2)) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=6,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_remote_call,op_server_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,7 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - save_lthis=g%lthis - call g_new_frame(g) - call use_var(g,g%codes(a+4)) - call cross_var(g,g%codes(a+4)) - call use_var(g,g%codes(a+8)) - call cross_var(g,g%codes(a+8)) - call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis - call gen_var_block(g,g%codes(a+2)) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,7 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_bcast_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - save_lthis=g%lthis - call g_new_frame(g) - call use_var(g,g%codes(a+2)) - call cross_var(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - call cross_var(g,g%codes(a+3)) - call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_recv_req_call,op_recv_assn_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+4)) - call cross_var(g,g%codes(a+4)) - call cross_all_vars(g) - save_lthis=g%lthis - call g_new_frame(g) - call cross_all_vars(g) - call use_var(g,g%codes(a+2)) - !call cross_var(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - call cross_var(g,g%codes(a+3)) - if(opcode==op_recv_assn_call) then - call use_var(g,g%codes(a+5)) - call cross_var(g,g%codes(a+5)) - endif - call gen_var_block(g,g%codes(a+1)) - call cross_all_vars(g) - g%lthis=save_lthis - case(op_do_at) - call use_var(g,g%codes(a)) - if(opcode2==0) then - call use_var(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - endif - call gen_var_block(g,g%codes(a+1)) - case(op_assign) - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+1)) - call use_var(g,g%codes(a+2),.true.) - case default - if(debug_g) write(*,*) 'VAR OP GENERIC>',op_names(opcode),g%codes(a:a+n-1) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - enddo - end select - - if(debug_g) write(*,*) 'END VAR OP> ',l,op_names(opcode) - - end subroutine gen_var_op - - !============================================================= - ! Variable assignment phase for a block with comm operations - !============================================================= - subroutine gen_var_comm_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - save_lthis=g%lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - call g_new_frame(g) - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - g%lthis=save_lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - end subroutine gen_var_comm_block - - !============================================================= - ! Variable assignment phase for inline shared proc body - !============================================================= - subroutine gen_var_shared_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - if(debug_g) write(*,*) 'VAR SHARED BLK>',blk - save_lthis=g%lthis - call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - call sort_var_list(g) - g%lthis=save_lthis - if(debug_g) write(*,*) 'END VAR SHARED BLK>',blk - end subroutine gen_var_shared_block - - !======================================================================= - ! Reverse list of vars (varlist/link) for current loop context - ! to yield list in ascending order of start index (varlist/link) - ! and also create sorted list by finish index yielding (evarlist/elink) - !======================================================================== - subroutine sort_var_list(g) - type(gen_state):: g - integer:: v,v2 - integer:: finish,next,nextv - v=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 - do while(v>0) - nextv=g%vardata(v)%link - g%vardata(v)%link=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=v - v2=g%lstack(g%lthis)%evarlist - finish=g%vardata(v)%finish - if(v2==0) then - g%lstack(g%lthis)%evarlist=v - g%vardata(v)%elink=0 - elseif(g%vardata(v2)%finish>=finish) then - g%vardata(v)%elink=v2 - g%lstack(g%lthis)%evarlist=v - else - do while(g%vardata(v2)%elink>0) - next=g%vardata(v2)%elink - if(g%vardata(next)%finish>=finish) exit - v2=next - enddo - g%vardata(v)%elink=g%vardata(v2)%elink - g%vardata(v2)%elink=v - endif - v=nextv - enddo - - if(debug_g) then - write(*,*) 'REVERSE OUT VARLIST>' - v=g%lstack(g%lthis)%varlist - do while(v>0) - write(*,*) v,g%vardata(v)%start - v=g%vardata(v)%link - enddo - write(*,*) 'SORT OUT EVARLIST>' - v=g%lstack(g%lthis)%evarlist - do while(v>0) - write(*,*) v,g%vardata(v)%finish - v=g%vardata(v)%elink - enddo - write(*,*) 'END SORT>' - endif - end subroutine sort_var_list - - !================================================== - ! Allocate variables on current list - ! This merges variables that are of the same type - ! but used at different times - !================================================== - subroutine alloc_var_list(g) - type(gen_state):: g - integer:: v,e,i - if(debug_g) write(*,*) 'ALLOCATING>',g%lthis - v=g%lstack(g%lthis)%varlist - e=g%lstack(g%lthis)%evarlist - do while(v/=0.and.e/=0) - i=min(g%vardata(v)%start,g%vardata(e)%finish+1) - do while(g%vardata(e)%finish+1==i) - call deallocate_var(g,e) - e=g%vardata(e)%elink - if(e==0) exit - enddo - if(debug_g) then - write(*,*) 'CONSIDER>',i,'#',v,g%vardata(v)%start,g%vardata(v)%finish,& - e,g%vardata(e)%start,g%vardata(e)%finish,g%vardata(e)%finish_on_assign - endif - if(g%vardata(e)%finish==i.and.& - g%vardata(v)%start==i.and.& - g%vardata(e)%finish_on_assign.and.& - iand(g%vardata(v)%flags,v_is_param+v_is_chan+v_is_result+v_is_shared)==0.and.& - iand(g%vardata(e)%flags,v_is_param+v_is_chan+v_is_result+v_is_shared)==0.and.& - g%vardata(v)%tno==g%vardata(e)%tno) then - call merge_vars(g,v,e) - v=g%vardata(v)%link - e=g%vardata(e)%elink - cycle - endif - do while(g%vardata(v)%start==i) - call allocate_var(g,v) - v=g%vardata(v)%link - if(v==0) exit - enddo - enddo - do while(e/=0) - call deallocate_var(g,e) - e=g%vardata(e)%elink - enddo -!!$ v=g%lstack(g%lthis)%varlist -!!$ do while(v/=0) -!!$ write(34,*) g%vardata(v)%index,g_var_at_index_is_a_vect(g,v) -!!$ v=g%vardata(v)%link -!!$ enddo - end subroutine alloc_var_list - - !=========================================== - ! Allocate a single variable - !=========================================== - subroutine allocate_var(g,v) - type(gen_state),intent(inout):: g - integer,intent(in):: v - integer:: tno,idx,isvect - if(debug_g) write(*,*) 'Allocate ',v - if(iand(g%vardata(v)%flags,v_is_param+v_is_chan+v_is_result)==0) then - isvect=merge(2,1,g_var_at_index_is_a_vect(g,v)) - tno=g%vardata(v)%tno - if(tnopm_string) then - idx=0 - if(debug_g) write(*,*) 'no storage',tno - else - if(debug_g) write(*,*) 'Freelist',tno,g%lstack(g%lthis)%free(isvect,tno) - if(g%lstack(g%lthis)%free(isvect,tno)/=0) then - idx=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=g%vardata(idx)%free - g%vardata(idx)%gflags=ior(g%vardata(idx)%gflags,var_is_recycled) - idx=abs(g%vardata(idx)%index) - if(debug_g) write(*,*) 'get free',idx - else - g%index=g%index+1 - idx=-g%index - endif - endif - else - if(debug_g) write(*,*) 'not crossing',g%vardata(v)%state==var_state_crossing - idx=0 - endif - if(debug_g) write(*,*) 'ALLOCATED>',v,idx,g%lthis - g%vardata(v)%index=idx - end subroutine allocate_var - - !=========================================== - ! Deallocate a single variable - !=========================================== - subroutine deallocate_var(g,v) - type(gen_state),intent(inout):: g - integer,intent(in):: v - integer:: tno,isvect - if(g%vardata(v)%index/=0) then - if(iand(g%vardata(v)%flags,v_is_chan+v_is_param+v_is_result+v_is_shared)==0) then - tno=g%vardata(v)%tno - isvect=merge(2,1,g_var_at_index_is_a_vect(g,v)) - if(debug_g) write(*,*) 'Deallocate',v,tno,isvect - g%vardata(v)%free=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=v - endif - endif - end subroutine deallocate_var - - !=========================================== - ! Merge v and e into a single variable - !=========================================== - subroutine merge_vars(g,v,e) - type(gen_state),intent(inout):: g - integer,intent(in):: v,e - if(g%vardata(e)%index==0.or.& - (g_var_at_index_is_a_vect(g,v).neqv.g_var_at_index_is_a_vect(g,e))) then - call allocate_var(g,v) - else - g%vardata(v)%index=abs(g%vardata(e)%index) - g%vardata(e)%gflags=ior(g%vardata(e)%gflags,var_is_recycled) - if(debug_g) then - write(*,*) 'MERGED>',g%vardata(v)%index - endif - endif - end subroutine merge_vars - - !================================================================= - ! Use a variable - called in variable allocation phase - ! Employs simple state engine to determine how a variable needs - ! to be stored - !================================================================= - recursive subroutine use_var(g,avar,isassign) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - logical,intent(in),optional:: isassign - integer:: kind,state,i,j,var,flags,tno - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_used, & ! var_state_unused - var_state_used, & ! var_state_open - var_state_used, & ! var_state_used - var_state_crossing, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_used & ! var_state_closed - /) - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - if(debug_g) write(*,*) 'USE VAR> ',var !,g_kind(g,var),g_v1(g,var) - kind=g_kind(g,var) - select case(kind) - case(v_is_group) - do i=1,g_v1(g,var) - call use_var(g,g_ptr(g,var,i),isassign) - enddo - case(v_is_sub,v_is_vsub) - call use_var(g,g_v1(g,var),isassign) - call use_var(g,g_v2(g,var),isassign) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) - call use_var(g,g_v1(g,var),isassign) - !g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) - continue - case(v_is_cove) - call use_var(g,g_v2(g,var),isassign) - g%varindex(var)=g%varindex(g_v2(g,var)) - case(v_is_alias) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_chan_vect) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case default - i=g%varindex(var) - if(i==0) then - g%nvars=g%nvars+1 - if(debug_g) write(*,*) 'CREATE>',var,g%nvars - i=g%nvars - if(kind==v_is_parve) then - g%vardata(i)%tno=pm_logical - flags=v_is_param - g%vardata(i)%name=0 - elseif(kind==v_is_ve) then - call use_var(g,g_v1(g,var)) - g%vardata(i)%tno=pm_logical - flags=0 - g%vardata(i)%name=0 - else - flags=g_v2(g,var) - tno=g_type(g,var) - g%vardata(i)%tno=tno - g%vardata(i)%name=g_v1(g,var) - endif - g%vardata(i)%flags=flags - if(iand(g%taints,proc_is_comm)/=0.and.& - iand(flags,v_is_param+v_is_result)/=0) then - if(iand(flags,v_is_shared)/=0) then - g%vardata(i)%state=var_state_used - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%state=var_state_crossing - if(iand(flags,v_is_result)/=0) then - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%lthis=g%lthis+1 - endif - endif - else - g%vardata(i)%lthis=g%lthis - g%vardata(i)%state=var_state_used - endif - g%vardata(i)%outer_lthis=g%vardata(i)%lthis - g%vardata(i)%start=g%lstack(g%lthis)%idx - g%vardata(i)%finish=g%vardata(i)%start - g%vardata(i)%index=0 - g%vardata(i)%link=g%lstack(g%lthis)%varlist - g%vardata(i)%gflags=0 - g%lstack(g%lthis)%varlist=i - g%vardata(i)%oindex=var - g%vardata(i)%finish_on_assign=.false. - g%varindex(var)=i - if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link - else - g%vardata(i)%state=new_state(g%vardata(i)%state) - g%vardata(i)%finish=g%lstack(g%vardata(i)%lthis)%idx - g%vardata(i)%outer_lthis=min(g%vardata(i)%outer_lthis,g%lthis) - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,& - merge(var_is_reused,var_is_used,iand(g%vardata(i)%gflags,var_is_used)/=0)) - if(debug_g) then - write(*,*) 'CONSIDER>',i,present(isassign) - endif - g%vardata(i)%finish_on_assign=present(isassign) - endif - end select - end subroutine use_var - - !=========================================================== - ! In variable allocation phase - flag all active variables - ! when a comm op is encountered - !============================================================ - subroutine cross_all_vars(g) - type(gen_state),intent(inout):: g - integer:: var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - g%loop_contains_shared=.true. - if(debug_g) write(*,*) 'CROSS ALL' - var=g%lstack(g%lthis)%varlist - do while(var>0) - if(debug_g) write(*,*) 'CROSS',var,'IN CROSS ALL' - call cross_var_at_index(g,var) - var=g%vardata(var)%link - end do - if(debug_g) write(*,*) 'CROSSED ALL' - end subroutine cross_all_vars - - !============================================================ - ! Flag a single variable crossed by comm op - !============================================================ - subroutine cross_var_at_index(g,i) - type(gen_state),intent(inout):: g - integer,intent(in):: i - integer:: state - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_unused, & ! var_state_unused - var_state_open, & ! var_state_open - var_state_used_before, & ! var_state_used - var_state_used_before, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_closed & ! var_state_closed - /) - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(i==0) return - if(g%vardata(i)%lthis/=g%lthis) return - if(iand(g%vardata(i)%flags,v_is_shared)/=0) return - state=g%vardata(i)%state - if(debug_g) write(*,*) 'Crossing',i,state,new_state(state) - g%vardata(i)%state=new_state(state) - end subroutine cross_var_at_index - - !================================================================== - ! Mark a variable as crossed (forced -not dependent on prior state) - !================================================================== - recursive subroutine cross_var(g,avar) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - integer:: i,var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - select case(g_kind(g,var)) - case(v_is_group) - do i=1,g_v1(g,var) - call cross_var(g,g_ptr(g,var,i)) - enddo - case(v_is_sub,v_is_vsub) - call cross_var(g,g_v1(g,var)) - call cross_var(g,g_v2(g,var)) - case(v_is_elem,v_is_unit_elem) - call cross_var(g,g_v1(g,var)) - case(v_is_alias) - call cross_var(g,g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_ve,v_is_cove) - continue - case default - i=g%varindex(var) - if(i/=0) then - if(g%vardata(i)%lthis==g%lthis.and.& - iand(g%vardata(i)%flags,v_is_shared)==0) then - !g%vardata(i)%state=var_state_crossing# - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,var_is_comm_op_par) - endif - endif - end select - end subroutine cross_var - - !============================================================ - ! If a variable was created outside of an iterative loop - ! then its lifetime must extend at least to the end of that - ! loop - !============================================================ - subroutine extend_finish_to_loop(g,loop_start_idx,loop_finish_idx,last_var_before_loop) - type(gen_state):: g - integer,intent(in):: loop_start_idx,loop_finish_idx,last_var_before_loop - integer:: var - ! Loop over vars created before loop - var=last_var_before_loop - do while(var>0) - if(g%vardata(var)%lthis==g%lthis) then - if(g%vardata(var)%finish>=loop_start_idx) then - g%vardata(var)%finish=loop_finish_idx - endif - endif - var=g%vardata(var)%link - end do - end subroutine extend_finish_to_loop - - - !**************************************************** - ! PHASE II - Generating FORTRAN code - !**************************************************** - - !============================================================ - ! Generate code for a block of wordcode operations - !============================================================ - recursive subroutine gen_block(g,loc) - type(gen_state):: g - integer,intent(in):: loc - integer:: l,save_last_ve - save_last_ve=g%last_ve - g%last_ve=0 - l=loc - do while(l>0) - call gen_op(g,l) - l=g%codes(l) - enddo - call gen_close_ifs(g,save_last_ve) - g%last_ve=save_last_ve - end subroutine gen_block - - !============================================================ - ! Generate code for single wordcode - ! operation - !============================================================ - recursive subroutine gen_op(g,loc) - type(gen_state):: g - integer,intent(in):: loc - integer:: opcode,opcode2,n,a,arg,save_lthis,l,ll,i,j,k,m,tno - logical:: ok,need_endif - - if(pm_debug_level>0) then - if(loc+comp_op_arg0>size(g%codes)) then - write(*,*) 'loc=',l,size(g%codes) - call pm_panic('gen_op bad loc') - endif - endif - - l=loc - - opcode=g%codes(l+comp_op_opcode) - opcode2=g%codes(l+comp_op_opcode2) - n=g%codes(l+comp_op_nargs) - a=l+comp_op_arg0 - - if(debug_g) write(*,*) 'GEN OP>',op_names(opcode),opcode2,n,'>',g%codes(a:a+n-1) - - if(pm_opts%ftn_comment_ops) then - call out_str(g,'! '//trim(op_names(opcode))) - do i=1,min(n,15) - call out_char(g,' ') - call out_idx(g,abs(g%codes(a+i-1))) - enddo - if(n>15) call out_str(g,' ...') - call out_new_line(g) - endif - - if(pm_opts%ftn_comment_lines) then - call out_char_idx(g,'!',g%codes(l+comp_op_line)/modl_mult) - call out_line(g,trim(pm_name_as_string(g%context,iand(g%codes(l+comp_op_line),modl_mult-1)))) - endif - - if(pm_opts%ftn_annotate) then - call out_char_idx(g,'!',merge(1000,0,g%lstack(g%lthis)%loop_active)+g%lthis) - call out_new_line(g) - endif - - select case(opcode) - case(op_if,op_if_shared) - if(opcode==op_if_shared) call gen_loop(g,l,.true.) - if(g%codes(a+1)/=0.or.g%codes(a+2)/=0) then - call out_simple(g,'IF($3) THEN',l) - call gen_block(g,g%codes(a+1)) - call gen_loop(g,l,.true.) - call out_simple(g,'ELSE',l) - call gen_block(g,g%codes(a+2)) - call gen_loop(g,l,.true.) - call out_line(g,'ENDIF') - endif - case(op_if_shared_node) - if(g%codes(a+1)/=0.or.g%codes(a+2)/=0) then - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE>1) THEN') - call gen_block(g,g%codes(a+1)) - call out_line(g,'ELSE') - call gen_block(g,g%codes(a+2)) - call out_line(g,'ENDIF') - endif - case(op_loop) - if(opcode2/=0) then - ! Loop contains shared operations so must - ! be places outside parallel loops - call gen_loop(g,l,.true.) - if(g_is_vect(g,g%codes(a+2))) then - call out_simple(g,'DO WHILE(ANY($#2))',l) - else - call out_simple(g,'DO WHILE($2)',l) - endif - call gen_block(g,g%codes(a+1)) - call gen_loop(g,l,.true.) - call out_line(g,'ENDDO ! LOOP') - else - call gen_loop(g,l,.false.) - call out_simple(g,'DO WHILE($2)',l) - call gen_block(g,g%codes(a+1)) - call out_line(g,'ENDDO ! LOOP') - endif - case(op_comm_block) - call gen_comm_block(g,l,g%codes(a+1),'$2') - case(op_comm_proc) - call gen_comm_block(g,l,g%codes(a+1),' ') - case(op_inline_shared) - if(pm_opts%ftn_annotate) call out_line(g,'! START SHARED BLOCK') - call gen_shared_block(g,l,g%codes(a+1)) - if(pm_opts%ftn_annotate) call out_line(g,'! END SHARED BLOCK') - case(op_comm_inline) - call out_line(g,'op_comm_inline') - call gen_loop(g,l,.true.) - case(op_do_loop) - call gen_loop(g,l,.true.) - do i=n/2,1,-1 - call out_str(g,'DO I') - call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) - call out_str(g,'=0,-1+') - call out_arg(g,g%codes(a+i+n/2),arg_no_index) - call out_new_line(g) - enddo - do i=n/2,1,-1 - call out_arg(g,g%codes(a+i),0) - call out_str(g,'=I') - call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) - call out_new_line(g) - enddo - call out_char_idx(g,'I',g%lthis) - call out_str(g,'=1+') - call out_char_idx(g,'I',0) - call out_char_idx(g,'_',g%lthis) - do i=2,n/2 - call out_char(g,'+') - call out_arg(g,g%codes(a+i+n/2-1),0) - call out_str(g,'*(I') - call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) - enddo - do i=2,n/2 - call out_char(g,')') - enddo - call out_new_line(g) - g%lstack(g%lthis)%nloops=n/2 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.true. - case(op_nested_loop) - call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+1) - g%lstack(g%lthis)%loop_mode=loop_is_nested - case(op_blocked_loop) - call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+n-1) - g%lstack(g%lthis)%loop_mode=loop_is_nested - call gen_loop(g,l,.false.) - do i=1,n-2 - call out_arg(g,g%codes(a+i),0) - call out_str(g,'=I') - call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) - call out_new_line(g) - enddo - case(op_skip_empty) - call gen_active_check_start(g,l) - call gen_block(g,g%codes(a+1)) - call gen_active_check_end(g,l) - case(op_head_node) - call gen_loop(g,l,.true.) - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - call gen_block(g,g%codes(a+1)) - call out_line(g,'ENDIF') - case(op_over) - call gen_loop(g,l,.true.) - call gen_over_block(g,l,g%codes(a+1)) - call gen_loop(g,l,.true.) - case(op_call) - call gen_loop(g,l,.false.) - if(pm_opts%ftn_annotate.and..not.pm_opts%ftn_name_procs) then - call out_comment_line(g,trim(pm_name_as_string(g%context,g_procname(g,opcode2)))) - endif - call out_str(g,'CALL PM__P') - call out_idx(g,opcode2) - if(pm_opts%ftn_name_procs) then - call out_ftn_name(g,g_procname(g,opcode2)) - endif - call out_char(g,'(') - do i=1,n-1 - call out_call_arg(g,g%codes(a+i),0) - call out_comma(g) - enddo - call out_close(g) - call out_new_line(g) - case(op_comm_call) - if(g%codes(a)>0) then - call gen_stacked_ve(g,l,g%codes(a)) - endif - call gen_loop(g,l,.true.) - if(pm_opts%ftn_annotate.and..not.pm_opts%ftn_name_procs) then - call out_comment_line(g,trim(pm_name_as_string(g%context,g_procname(g,opcode2)))) - endif - call out_str(g,'CALL PM__P') - call out_idx(g,opcode2) - if(pm_opts%ftn_name_procs) then - call out_ftn_name(g,g_procname(g,opcode2)) - endif - call out_str(g,'(N') - call out_idx(g,g%lthis) - call out_char(g,',') - if(g%codes(a)>0) then - call out_call_arg(g,g%codes(a),arg_no_index+arg_comm_arg) - call out_char(g,',') - endif - do i=1,n-1 - call out_call_arg(g,g%codes(a+i),arg_no_index+arg_comm_arg) - call out_comma(g) - enddo - call out_close(g) - call out_new_line(g) - case(op_comm_loop,op_comm_loop_par) - call gen_loop(g,l,.true.) - need_endif=.false. - if(g_is_vect(g,g%codes(a+2))) then - if(opcode==op_comm_loop_par) then - call out_simple(g,'LOK=PM__TEST_LOOP(ANY($#2))',l) - else - call out_simple(g,'LOK=ANY($#2)',l) - endif - call out_line(g,'DO WHILE(LOK)') - call out_simple(g,'IF($2) THEN',l) - need_endif=.true. - else - call out_simple(g,'DO WHILE($2)',l) - endif - call gen_block(g,g%codes(a+1)) - call gen_loop(g,l,.true.) - if(g_is_vect(g,g%codes(a+2))) then - if(opcode==op_comm_loop_par) then - call out_simple(g,'LOK=PM__TEST_LOOP(ANY($#2))',l) - else - call out_simple(g,'LOK=ANY($#2)') - endif - endif - if(need_endif) call out_line(g,'ENDIF') - call out_line(g,'ENDDO ! COMM LOOP') - case(op_remote_call,op_remote_send_call) - call gen_loop(g,l,.true.) - if(pm_opts%ftn_annotate) call out_line(g,'!START REMOTE CALL') - call gen_mpi_remote_call(g,l,opcode==op_remote_send_call) - if(pm_opts%ftn_annotate) call out_line(g,'!END REMOTE CALL') - case(op_server_call,op_collect_call) - call gen_loop(g,l,.true.) - call gen_mpi_collect_call(g,l,opcode==op_collect_call) - case(op_bcast_call) - call gen_loop(g,l,.true.) - if(g%codes(a)==0) then - call gen_mpi_bcast_call(g,l) - else - call gen_mpi_masked_bcast_call(g,l) - endif - - case(op_do_at) - call gen_loop(g,l,.false.) - if(opcode2==1) then - call out_simple(g,'IDO=I$N',n=g%lthis) - else - call out_simple(g,'IDO=$2+1',l) - endif - i=g_lthis(g,g%codes(a+merge(2,3,opcode2==1))) - if(i/=0.and.g%lstack(i)%loop_active) then - write(*,*) 'lthis=',g%lthis,'from',g%codes(a+3) - call pm_panic('Loop active in op_do_at') - endif - g%lalt=i - call gen_block(g,g%codes(a+1)) - g%lalt=-1 - case(op_get_size) - call gen_loop(g,l,.true.) - if(g_kind(g,g%codes(a+2))==v_is_group) then - call out_simple_part(g,'$1=SIZE(',l) - call out_arg(g,g_ptr(g,g%codes(a+2),1),0) - call out_line(g,'%P)') - else - call out_simple(g,'$1=SIZE($2%E1%P)',l) - endif - case(op_dref) - ! This does not generate code - ! - just present for Phase I - continue - case(op_wrap) - ! Save the current loop context for variable - !write(*,*) 'WRAP',g%lthis,'to',g%codes(a+1) - call g_set_v2(g,g%codes(a+1),g%lthis) - - case(op_sync) - call gen_loop(g,l,.true.) - - case(op_isend) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_send(g,g%codes(a+2),'PM__DATA_TAG','ISEND',mode_array) - case(op_irecv) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_recv(g,g%codes(a+2),'PM__DATA_TAG','IRECV',mode_array,.false.) - case(op_recv) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_recv(g,g%codes(a+2),'PM__DATA_TAG','RECV',mode_array,.false.) - - case(op_isend_grid) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_send_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','ISEND',g%codes(a+1),mode_array) - case(op_irecv_grid) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','IRECV',g%codes(a+1),mode_array,.false.) - case(op_recv_grid,op_recv_grid_resend) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','RECV',g%codes(a+1),mode_array,.false.) - - case(op_isend_offset) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_send_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','ISEND',g%codes(a+1),mode_array) - call gen_active_check_end(g,l) - case(op_irecv_offset) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','IRECV',g%codes(a+1),mode_array,.false.) - call gen_active_check_end(g,l) - case(op_recv_offset,op_recv_offset_resend) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','RECV',g%codes(a+1),mode_array,.false.) - call gen_active_check_end(g,l) - case(op_isend_reply) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_send(g,g%codes(a+2),'PM__DATA_TAG','RSEND',mode_vect) - call gen_active_check_end(g,l) - - case(op_sync_mess) - call gen_loop(g,l,.true.) - call gen_sync_mess(g,l,a,n) - - case(op_broadcast) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_bcast(g,g%codes(a+1)) - call gen_active_check_end(g,l) - case(op_broadcast_shared) - call gen_active_check_start(g,l) - call gen_mpi_bcast(g,g%codes(a+1),isshared=.true.) - call gen_active_check_end(g,l) - case(op_broadcast_val) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$3',l) - call out_simple(g,& - 'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) $1=$2') - call gen_mpi_bcast(g,g%codes(a+1)) - call gen_active_check_end(g,l) - - case(op_broadcast_disp) - !!! Needs rewriting a part of broader fix for this operation - call out_simple(g,'JNODE=$2',l) - if(n>4) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%lthis) - call gen_mpi_bcast_part(g,g%codes(a+3),.false.,'RBUFFER%P','1','NREQ',mode_vect) - else - !!! Do we need to check if grid or not? - call gen_mpi_bcast_part(g,g%codes(a+3),.false.,'$A','1','SIZE($A)',& - mode_vect,dvv=g%codes(a+1)) - endif - - case(op_isend_req,op_isend_assn) - call gen_active_check_start(g,l) - !call out_line(g,'write(*,*) "ISEND_ASSN"') - call out_simple(g,'JNODE=$2',l) - if(n>6) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$6,NREQ)',l,n=g%lthis) - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_line(g,'CALL MPI_ISEND(NREQ,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call out_line(g,'PM__PUSH_MESSAGE(JMESS)') - call gen_mpi_send_part(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND','RBUFFER%P','1','NREQ',mode_vect) - if(opcode==op_isend_req) then - call gen_mpi_recv_part(g,g%codes(a+3),'PM__DATA_TAG','IRECV',.false.,'RBUFFER%P','1','NREQ',mode_vect) - else - call gen_mpi_send_part(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND','RBUFFER%P','1','NREQ',mode_vect) - endif - else - if(g_kind(g,g%codes(a+1))==v_is_group) then - call out_simple(g,'NREQ=$X',x=g_ptr(g,g%codes(a+1),2)) - else - call out_simple(g,'NREQ=SIZE($#1)',l) - endif - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_line(g,'CALL MPI_ISEND(NREQ,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call gen_mpi_send_disp_or_grid(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND',g%codes(a+1),mode_vect) - if(opcode==op_isend_req) then - call gen_mpi_recv_disp_or_grid(g,g%codes(a+4),'PM__DATA_TAG','IRECV',g%codes(a+1),mode_vect,.false.) - else - call gen_mpi_send_disp_or_grid(g,g%codes(a+4),'PM__EXTRA_REQ_TAG','ISEND',g%codes(a+1),mode_vect) - endif - endif - call gen_active_check_end(g,l) - - case(op_recv_reply) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - if(n>4) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%lthis) - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call gen_mpi_recv_part(g,g%codes(a+3),'PM__DATA_TAG','RECV',.true.,'RBUFFER%P','1','NREQ',mode_vect) - else - call gen_mpi_recv_disp_or_grid(g,g%codes(a+4),'PM__DATA_TAG','RECV',g%codes(a+1),mode_vect,.true.) - endif - call gen_active_check_end(g,l) - case(op_recv_req_calL,op_recv_assn_call) - call gen_active_check_start(g,l) - call gen_mpi_recv_call(g,l,g%codes(a+1),opcode==op_recv_assn_call) - call gen_active_check_end(g,l) - case(op_active) - call gen_stacked_ve(g,l,g%codes(a),g%codes(a+1)) - call gen_loop(g,l,.true.) - case(op_wshare) - call out_simple_scalar(g,'$1=PM__WSHARE($2%E1%P,$3,$4,$5)',l) - case(op_sys_node) - call out_simple_scalar(g,'$1=PM__SYS_NODE',l) - case(op_sys_nnode) - call out_simple_scalar(g,'$1=PM__SYS_NNODE',l) - case(op_this_node) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE',l) - case(op_this_nnode) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NNODE',l) - case(op_shared_node) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE',l) - case(op_shared_nnode) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NNODE',l) - case(op_is_shared) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%IS_SHARED',l) - case(op_is_par) - call out_simple_scalar(g,'$1=PM__CONC_DEPTH.EQ.0',l) - case(op_get_dims) - call gen_loop(g,l,.false.) - m=(n-2)/2 - if(m==1) then - call out_simple(g,'$1=MERGE($3,$2,$3.GT.0.AND.$2.NE.1)',l) - else - call out_simple(g,'IF($X.GT.1)THEN',l,x=m+1) - do i=m+2,m+m+1 - call out_simple(g,'Z%P($N)=$X',l,n=i-m-1,x=i) - enddo - call out_simple(g,'CALL MPI_DIMS_CREATE(INT($X),$N,Z%P,JERRNO)',l,n=m,x=m+1) - do i=1,m - call out_simple(g,'$X=Z%P($N)',l,n=i,x=i) - enddo - call out_line(g,'ELSE') - do i=1,m - call out_simple(g,'$X=1',l,x=i) - enddo - call out_line(g,'ENDIF') - endif - case(op_push_node_split) - call out_simple_scalar(g,'CALL PM__PUSH_NODE_SPLIT($1)',l) - case(op_push_node_distr) - call gen_loop(g,l,.false.) - call out_line(g,'CALL PM__PUSH_NODE_DISTR()') - case(op_push_node_conc) - call gen_loop(g,l,.false.) - call out_line(g,'CONC_DEPTH=CONC_DEPTH+1') - case(op_pop_node_conc) - call gen_loop(g,l,.false.) - call out_line(g,'CONC_DEPTH=CONC_DEPTH-1') - case(op_pop_node) - call gen_loop(g,l,.true.) - call out_line(g,'CALL PM__POP_NODE()') - case(op_make_poly) - call out_simple_scalar(g,'IF(ALLOCATED($1%P)) DEALLOCATE($1%P)',l) - if(g_type(g,g%codes(a+2))<=pm_string) then - call out_simple(g,'ALLOCATE($1%P,SOURCE=PM__BOX$S($2))',l,& - x=g_type(g,g%codes(a+2))) - else - call out_simple(g,'ALLOCATE($1%P,SOURCE=$2)',l) - endif - case(op_any) - call out_simple_scalar(g,'$1=.FALSE.',l) - call out_simple(g,'SELECT TYPE(POLYVAR=>$3%P)',l) - if(opcode2<=pm_string) then - call out_simple(g,'TYPE IS(PM__T$S)',x=opcode2) - call out_simple(g,'$2=POLYVAR%P',l) - else - call out_simple(g,'TYPE IS(PM__T$N)',n=opcode2) - call out_simple(g,'$2=POLYVAR',l) - endif - call out_simple(g,'$1=.TRUE.',l) - call out_line(g,'END SELECT') - - case(op_intersect_seq) - call out_simple_scalar(g,& - 'CALL PM__INTERSECT_SEQ($5,$6,$7,$8,$9,$(10),$(11),$(12),$1,$2,$3,$4)',l) - case(op_intersect_aseq) - if(opcode2==0) then - call out_simple_scalar(g,'CALL PM__INTERSECT_ASEQ($2,$3,$4,$5,$6,$1)',l) - elseif(opcode2==1) then - call out_simple_scalar(g,'CALL PM__OVERLAP_ASEQ($2,$3,$4,$5,$6,$1)',l) - else - call out_simple_scalar(g,'CALL PM__OVERLAP_ASEQ($2,$3,$4,$5,$6,$7,$1)',l) - endif - case(op_assign) - if(.not.(g_vars_are_merged(g,g%codes(a+1),g%codes(a+2)).or.& - g_var_is_dead(g,g%codes(a+1)))) then - if(pm_opts%ftn_annotate) then - call out_simple(g,'!ASSIGN (opcode2=$N)',n=abs(opcode2)) - endif - call out_simple_scalar(g,'$1=$2',l) - else - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'Eliminated merge assign:'//& - merge('Y','N',g_var_is_dead(g,g%codes(a+1)))//& - merge('Y','N',g_vars_are_merged(g,g%codes(a+1),g%codes(a+2)))) - endif - endif - case(op_assign_farray) - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'! ASSIGN FARRAY') - endif - call out_simple_scalar(g,'$1=$2',l) - case(op_and_ve) - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'! AND_VE') - endif - call out_simple_scalar(g,'$1=$2',l) - case(op_andnot_ve) - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'! AND_NOT_VE') - endif - call out_simple_scalar(g,'$1=.NOT.($2)',l) - case(op_print) - call out_simple_scalar(g,'CALL PM__PRINT($1)',l) - case(op_concat) - call out_simple_scalar(g,'$1=PM__CONCAT_STR($2,$3)',l) - case(op_check) - call out_simple_scalar(g,'IF(.NOT.$2) CALL PM__ABORT($1)',l) - - case(op_array,op_var_array) - ! V n x - call out_simple_scalar(g,'IF(ALLOCATED($1%E1%P)) DEALLOCATE($1%E1%P)',l) - call out_simple(g,'ALLOCATE($1%E1%P(MAX($4,1)),SOURCE=$2)',l) - call out_simple(g,'$1%E2=$3',l) - if(g_type(g,g%codes(a+3))==pm_long) then - call out_simple(g,'$1%E3=$4',l) - endif - case(op_fill) - call gen_loop(g,l,.false.) - call out_simple(g,'DO IJ=$N+1,$3',l,n=opcode2) - call out_arg(g,g%codes(a+1),arg_no_index) - call out_char(g,'(') - if(g_is_vect(g,g%codes(a+1))) then - call out_str(g,'IJ,I') - call out_idx(g,g%lthis) - call out_str(g,')=') - else - call out_str(g,'IJ)=') - endif - call out_arg(g,g%codes(a+2),0) - call out_new_line(g) - call out_line(g,'ENDDO') - case(op_break_loop) - call gen_loop(g,l,.true.) - case(op_get_rf) - call out_simple_scalar(g,'$1=$2',l) - case(op_open_file) - call out_simple_scalar(g,'$1=PM__FILE_OPEN($3%P,$4,$5,$6,$7,$8,$9,$(10),$2)',l) - case(op_close_file) - call out_simple_scalar(g,'CALL MPI_FILE_CLOSE($2,$1)',l) - case(op_seek_file) - call out_simple_scalar(g,'CALL MPI_FILE_SEEK($2,$3,MPI_SEEK_SET,$1)',l) - case(op_read_file) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple_scalar(g,'CALL MPI_FILE_READ_ALL($2,$3,1,JBASE,MPI_STATUS_IGNORE,$1)',l) - case(op_write_file) - call gen_loop(g,l,.false.) - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL MPI_FILE_WRITE($2,$3,1,JBASE,MPI_STATUS_IGNORE,$1)',l,& - x=g_type(g,g%codes(a+3))) - call out_line(g,'ENDIF') - call out_simple(g,'CALL PM__SYNC_FILE_WRITE($2,$1)',l) - case(op_read_file_array) - call gen_loop(g,l,.false.) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,$4,JTYPE,JN,LNEW)',l) - call out_simple(g,'CALL MPI_FILE_READ_ALL($2,$3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - case(op_write_file_array) - call gen_loop(g,l,.false.) - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,$4,JTYPE,JN,LNEW)',l) - call out_simple(g,'CALL MPI_FILE_WRITE($2,$3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - call out_line(g,'ENDIF') - call out_simple(g,'CALL PM__SYNC_FILE_WRITE($2,$1)',l) - case(op_read_file_tile,op_write_file_tile) - call gen_loop(g,l,.true.) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL PM__FILE_SET_VIEW($2,JBASE,$#4,N$N,$5,$1,OFFSET)',l,& - n=g%lthis) - call out_simple(g,'IF($1==0) THEN',l) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+5))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,N$N,JTYPE,JN,LNEW)',l,n=g%lthis) - if(opcode==op_read_file_tile) then - call out_simple(g,'CALL MPI_FILE_READ_ALL($2,$#3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - else - call out_simple(g,'CALL MPI_FILE_WRITE_ALL($2,$#3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - endif - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - call out_line(g,'ENDIF') - call out_simple(g,'CALL PM__FILE_RESET_VIEW($2,OFFSET,$1)',l) - case(op_io_error_string) - call out_simple_scalar(g,'$1=PM__IO_ERROR_STRING($2)',l) - - case(op_and) - call out_simple_scalar(g,'$1=$2.AND.$3',l) - case(op_or) - call out_simple_scalar(g,'$1=$2.OR.$3',l) - case(op_eq_l) - call out_simple_scalar(g,'$1=$2.EQV.$3',l) - case(op_ne_l) - call out_simple_scalar(g,'$1=$2.NEQV.$3',l) - case(op_not) - call out_simple_scalar(g,'$1=.NOT.$2',l) - case(op_assign_l) - call out_simple_scalar(g,'$1=$2',l) - - case(op_string_i) - call out_simple_scalar(g,'$1=PM__INT_TO_STR($2)',l) - case(op_string_ln) - call out_simple_scalar(g,'$1=PM__LONG_TO_STR($2)',l) - case(op_string_offset) - call out_simple_scalar(g,'$1=PM__OFFSET_TO_STR($2)',l) - case(op_string_i64) - call out_simple_scalar(g,'$1=PM__INT64_TO_STR($2)',l) - case(op_string_r) - call out_simple_scalar(g,'$1=PM__REAL_TO_STR($2)',l) - case(op_string_l) - call out_simple_scalar(g,'$1=PM__BOOL_TO_STR($2)',l) - case(op_string_d) - call out_simple_scalar(g,'$1=PM__DOUBLE_TO_STR($2)',l) - case(op_add_i,op_add_ln,op_add_offset,op_add_i8,op_add_i16,op_add_i32,& - op_add_i64,op_add_r,op_add_d,op_add_c,op_add_dc) - call out_simple_scalar(g,'$1=$2+$3',l) - case(op_sub_i,op_sub_ln,op_sub_offset,op_sub_i8,op_sub_i16,op_sub_i32,& - op_sub_i64,op_sub_r,op_sub_d,op_sub_c,op_sub_dc) - call out_simple_scalar(g,'$1=$2-$3',l) - case(op_mult_i,op_mult_ln,op_mult_offset,op_mult_i8,op_mult_i16,op_mult_i32,& - op_mult_i64,op_mult_r,op_mult_d,op_mult_c,op_mult_dc) - call out_simple_scalar(g,'$1=$2*$3',l) - case(op_divide_i,op_divide_ln,op_divide_offset,op_divide_i8,op_divide_i16,op_divide_i32,& - op_divide_i64,op_divide_r,op_divide_d,op_divide_c,op_divide_dc) - call out_simple_scalar(g,'$1=$2/$3',l) - case(op_mod_i,op_mod_ln,op_mod_offset,op_mod_i8,op_mod_i16,op_mod_i32,& - op_mod_i64,op_mod_r,op_mod_d) - call out_simple_scalar(g,'$1=MODULO($2,$3)',l) - case(op_pow_i,op_pow_ln,op_pow_offset,op_pow_i8,op_pow_i16,op_pow_i32,& - op_pow_i64,op_pow_r,op_pow_d,op_pow_c,op_rpow_c,op_pow_dc,op_dpow_dc) - call out_simple_scalar(g,'$1=$2**$3',l) - case(op_uminus_i,op_uminus_ln,op_uminus_offset,op_uminus_i8,op_uminus_i16,op_uminus_i32,& - op_uminus_i64,op_uminus_r,op_uminus_d,op_uminus_c,op_uminus_dc) - call out_simple_scalar(g,'$1=-$2',l) - case(op_eq_i,op_eq_ln,op_eq_offset,op_eq_i8,op_eq_i16,op_eq_i32,& - op_eq_i64,op_eq_r,op_eq_d,op_eq_c,op_eq_dc) - call out_simple_scalar(g,'$1=$2.EQ.$3',l) - case(op_ne_i,op_ne_ln,op_ne_offset,op_ne_i8,op_ne_i16,op_ne_i32,& - op_ne_i64,op_ne_r,op_ne_d,op_ne_c,op_ne_dc) - call out_simple_scalar(g,'$1=$2.NE.$3',l) - case(op_gt_i,op_gt_ln,op_gt_offset,op_gt_i8,op_gt_i16,op_gt_i32,& - op_gt_i64,op_gt_r,op_gt_d) - call out_simple_scalar(g,'$1=$2.GT.$3',l) - case(op_ge_i,op_ge_ln,op_ge_offset,op_ge_i8,op_ge_i16,op_ge_i32,& - op_ge_i64,op_ge_r,op_ge_d) - call out_simple_scalar(g,'$1=$2.GE.$3',l) - case(op_max_i,op_max_ln,op_max_offset,op_max_i8,op_max_i16,op_max_i32,& - op_max_i64,op_max_r,op_max_d) - call out_simple_scalar(g,'$1=MAX($2,$3)',l) - case(op_min_i,op_min_ln,op_min_offset,op_min_i8,op_min_i16,op_min_i32,& - op_min_i64,op_min_r,op_min_d) - call out_simple_scalar(g,'$1=MIN($2,$3)',l) - case(op_assign_i,op_assign_ln,op_assign_offset,op_assign_i8,op_assign_i16,op_assign_i32,& - op_assign_i64,op_assign_r,op_assign_d,op_assign_c,op_assign_dc) - call out_simple_scalar(g,'$1=$2',l) - case(op_abs_i,op_abs_ln,op_abs_offset,op_abs_i8,op_abs_i16,op_abs_i32,& - op_abs_i64,op_abs_r,op_abs_d,op_abs_c,op_abs_dc) - call out_simple_scalar(g,'$1=ABS($2)',l) - case(op_pdiff_i,op_pdiff_ln,op_pdiff_offset,op_pdiff_i8,op_pdiff_i16,op_pdiff_i32,& - op_pdiff_i64,op_pdiff_r,op_pdiff_d) - call out_simple_scalar(g,'$1=DIM($2,$3)',l) - case(op_sign_i,op_sign_ln,op_sign_offset,op_sign_i8,op_sign_i16,op_sign_i32,& - op_sign_i64,op_sign_r,op_sign_d) - call out_simple_scalar(g,'$1=SIGN($2,$3) ! SIGN',l) - case(op_modulo_i,op_modulo_ln,op_modulo_offset,op_modulo_i8,op_modulo_i16,op_modulo_i32,& - op_modulo_i64,op_modulo_r,op_modulo_d) - call out_simple_scalar(g,'$1=MOD($2,$3)',l) - - case(op_bnot_i,op_bnot_ln,op_bnot_offset,& - op_bnot_i8,op_bnot_i16,op_bnot_i32,op_bnot_i64) - call out_simple_scalar(g,'$1=NOT($2)',l) - case(op_band_i,op_band_ln,op_band_offset,& - op_band_i8,op_band_i16,op_band_i32,op_band_i64) - call out_simple_scalar(g,'$1=IAND($2,$3)',l) - case(op_bor_i,op_bor_ln,op_bor_offset,& - op_bor_i8,op_bor_i16,op_bor_i32,op_bor_i64) - call out_simple_scalar(g,'$1=IOR($2,$3)',l) - case(op_bxor_i,op_bxor_ln,op_bxor_offset,& - op_bxor_i8,op_bxor_i16,op_bxor_i32,op_bxor_i64) - call out_simple_scalar(g,'$1=IEOR($2,$3)',l) - case(op_bshift_i,op_bshift_ln,op_bshift_offset,& - op_bshift_i8,op_bshift_i16,op_bshift_i32,op_bshift_i64) - call out_simple_scalar(g,'$1=ISHFT($2,$3)',l) - - case(op_acos_r,op_acos_d,op_acos_c,op_acos_dc) - call out_simple_scalar(g,'$1=ACOS($2)',l) - case(op_asin_r,op_asin_d,op_asin_c,op_asin_dc) - call out_simple_scalar(g,'$1=ASIN($2)',l) - case(op_atan_r,op_atan_d,op_atan_c,op_atan_dc) - call out_simple_scalar(g,'$1=ATAN($2)',l) - case(op_atan2_r,op_atan2_d) - call out_simple_scalar(g,'$1=ATAN2($2,$3)',l) - case(op_cos_r,op_cos_d,op_cos_c,op_cos_dc) - call out_simple_scalar(g,'$1=COS($2)',l) - case(op_cosh_r,op_cosh_d,op_cosh_c,op_cosh_dc) - call out_simple_scalar(g,'$1=COSH($2)',l) - case(op_exp_r,op_exp_d,op_exp_c,op_exp_dc) - call out_simple_scalar(g,'$1=EXP($2)',l) - case(op_log_r,op_log_d,op_log_c,op_log_dc) - call out_simple_scalar(g,'$1=LOG($2)',l) - case(op_log10_r,op_log10_d) - call out_simple_scalar(g,'$1=LOG10($2)',l) - case(op_sin_r,op_sin_d,op_sin_c,op_sin_dc) - call out_simple_scalar(g,'$1=SIN($2)',l) - case(op_sinh_r,op_sinh_d,op_sinh_c,op_sinh_dc) - call out_simple_scalar(g,'$1=SINH($2)',l) - case(op_sqrt_r,op_sqrt_d,op_sqrt_c,op_sqrt_dc) - call out_simple_scalar(g,'$1=SQRT($2)',l) - case(op_tan_r,op_tan_d,op_tan_c,op_tan_dc) - call out_simple_scalar(g,'$1=TAN($2)',l) - case(op_tanh_r,op_tanh_d,op_tanh_c,op_tanh_dc) - call out_simple_scalar(g,'$1=TANH($2)',l) - case(op_floor_r,op_floor_d) - call out_simple_scalar(g,'$1=FLOOR($2)',l) - case(op_ceil_r,op_ceil_d) - call out_simple_scalar(g,'$1=CEILING($2)',l) - - case(op_imag_c,op_imag_dc) - call out_simple_scalar(g,'$1=IMAG($2)',l) - case(op_conj_c,op_conj_dc) - call out_simple_scalar(g,'$1=CONJG($2)',l) - - case(op_int_ln,op_int_offset,op_int_r,op_int_d,& - op_int_i8,op_int_i16,op_int_i32,op_int_i64) - call out_simple_scalar(g,'$1=INT($2)',l) - case(op_long_i,op_long_offset,op_long_r,op_long_d,& - op_long_i8,op_long_i16,op_long_i32,op_long_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__LN)',l) - case(op_offset_i,op_offset_ln,op_offset_r,op_offset_d,& - op_offset_i8,op_offset_i16,op_offset_i32,op_offset_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__LN)',l) - case(op_real_i,op_real_ln,op_real_offset,op_real_d,& - op_real_i8,op_real_i16,op_real_i32,op_real_i64,op_real_c) - call out_simple_scalar(g,'$1=REAL($2)',l) - case(op_double_i,op_double_ln,op_double_offset,op_double_r,& - op_double_i8,op_double_i16,op_double_i32,op_double_i64,& - op_real_dc) - call out_simple_scalar(g,'$1=REAL($2,KIND=PM__D)',l) - case(op_i8_i,op_i8_ln,op_i8_offset,& - op_i8_i16,op_i8_i32,op_i8_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i8)',l) - case(op_i16_i,op_i16_ln,op_i16_offset,& - op_i16_i8,op_i16_i32,op_i16_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i16)',l) - case(op_i32_i,op_i32_ln,op_i32_offset,& - op_i32_i8,op_i32_i16,op_i32_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i32)',l) - case(op_i64_i,op_i64_ln,op_i64_offset,& - op_i64_i8,op_i64_i16,op_i64_i32) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i64)',l) - case(op_complex_r) - call out_simple_scalar(g,'$1=CMPLX($2,0.0)',l) - case(op_complex_d) - call out_simple_scalar(g,'$1=CMPLX($2,0.0d0,kind=PM__D)',l) - case(op_complex2_r) - call out_simple_scalar(g,'$1=CMPLX($2,$3)',l) - case(op_complex2_d) - call out_simple_scalar(g,'$1=CMPLX($2,$3,kind=PM__D)',l) - case(op_logical_return,op_miss_arg,op_default) - continue - - case default - write(*,*) opcode - write(*,*) op_names(opcode),op_names(opcode-1),op_names(opcode+1) - call pm_panic('cannot compile operation') - end select - -88 continue - - if(debug_g) write(*,*) 'GEN OP DONE> ',op_names(opcode),opcode2,n - - end subroutine gen_op - - !============================================================ - ! Implement an over command - ! - basically save/resore current loop state - ! to allow this to be overridden within the - ! block - !============================================================ - subroutine gen_over_block(g,l,blk) - type(gen_state):: g - integer,intent(in):: l,blk - type(gloop):: save_loop - save_loop=g%lstack(g%lthis) - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none - call gen_block(g,blk) - call gen_loop(g,l,.true.) - g%lstack(g%lthis)=save_loop - end subroutine gen_over_block - - !============================================================ - ! Generate code for block containing comm ops - !============================================================ - subroutine gen_comm_block(g,l,lnew,nc) - type(gen_state):: g - integer,intent(in):: l,lnew - character(len=*),intent(in):: nc - integer:: save_lthis,ll,save_last_ve - call gen_loop(g,l,.false.) - save_last_ve=g%last_ve - g%last_ve=0 - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - - if(pm_opts%ftn_annotate) call out_simple(g,'! BLOCK -> $N',n=g%lthis) - if(nc/=' ') call out_simple(g,'N$N='//nc,l,n=g%lthis) - call gen_vect_alloc(g) - g%lstack(g%lthis)%loop_active=.false. - ll=lnew - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call gen_loop(g,l,.true.) - call gen_vect_dealloc(g) - if(pm_opts%ftn_annotate) call out_simple(g,'!ENDBLOCK -> $N',n=g%lthis) - g%lthis=save_lthis - g%last_ve=save_last_ve - end subroutine gen_comm_block - - subroutine gen_mpi_recv_call(g,l,lnew,assn) - type(gen_state):: g - integer,intent(in):: l,lnew - logical,intent(in):: assn - integer:: a,save_lthis,ll,save_last_ve - a=l+comp_op_arg0 - !call out_line(g,'write(*,*) "RECV CALL"') - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_line(g,& - 'CALL MPI_PROBE(MPI_ANY_SOURCE,PM__REQ_TAG,JCOMM,PM__STAT,JERRNO)') - !call out_line(g,'write(*,*) "PROBED"') - call out_line(g,'JNODE=PM__STAT(MPI_SOURCE)') - call out_simple(g,'$2=JNODE',l) - save_last_ve=g%last_ve - g%last_ve=0 - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - call out_simple(g,'CALL MPI_RECV(N$N,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,MPI_STATUS_IGNORE,JERRNO)',n=g%lthis) - call gen_vect_alloc(g) - call gen_mpi_recv(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - if(assn) then - call gen_mpi_recv(g,g%codes(a+5),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - call out_line(g,'CALL PM__GET_SHARED_RANKS(WBUFFER%P,JNUMRANKS)') - call out_line(g,'DO JI=1,JNUMRANKS') - call out_line(g,'JNODE=WBUFFER%P(I)') - call gen_mpi_send(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call gen_mpi_send(g,g%codes(a+5),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call out_line(g,'ENDDO') - endif - !call out_line(g,'write(*,*) "RECVD CALL"') - ll=lnew - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call gen_loop(g,l,.true.) - call gen_vect_dealloc(g) - g%lthis=save_lthis - g%last_ve=save_last_ve - end subroutine gen_mpi_recv_call - - !============================================================ - ! Generate for block of code that is shared/invariant - ! with respect to the current context - !============================================================ - subroutine gen_shared_block(g,l,lnew) - type(gen_state):: g - integer,intent(in):: l,lnew - integer:: save_lthis,ll,save_last_ve - call gen_loop(g,l,.true.) - save_last_ve=g%last_ve - g%last_ve=0 - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none - if(pm_opts%ftn_annotate) call out_simple(g,'! SHARED BLOCK -> $N',n=g%lthis) - ll=lnew - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - if(pm_opts%ftn_annotate) call out_simple(g,'!END SHARED BLOCK -> $N',n=g%lthis) - g%lthis=save_lthis - g%last_ve=save_last_ve - end subroutine gen_shared_block - - subroutine g_new_frame(g) - type(gen_state),intent(inout):: g - g%ltop=g%ltop+1 - g%lthis=g%ltop - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 - g%lstack(g%lthis)%defer_free=0 - g%lstack(g%lthis)%idx=0 - g%lstack(g%lthis)%free=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.false. - end subroutine g_new_frame - - !============================================================ - ! If not in an active loop, generate required do loops - ! and masking statements - !============================================================ - subroutine gen_loop(g,l,isshared) - type(gen_state):: g - integer,intent(in):: l - logical,intent(in):: isshared - integer:: ve - logical:: shared - - ve=g%codes(l+comp_op_arg0) - shared=ve==shared_op_flag.or.isshared - if(shared) ve=0 - - ! Start up loops - if((.not.shared).and.(.not.g_loop_active(g))) then - call gen_loop_nest(g) - g%lstack(g%lthis)%loop_active=.true. - g%last_ve=0 - endif - - ! Close and re-open if statements - if(g%last_ve/=ve) then - call gen_if_nest(g,g%last_ve,ve) - g%last_ve=ve - endif - - ! Close down loops - if(shared.and.g_loop_active(g)) then - call gen_close_loops(g) - endif - - end subroutine gen_loop - - !========================================= - ! Are the loops for the current parallel - ! context running - !========================================= - function g_loop_active(g) result(ok) - type(gen_state):: g - logical:: ok - ok=g%lstack(g%lthis)%loop_active - end function g_loop_active - - !============================================================ - ! Generate loops spanning the current domain - !============================================================ - subroutine gen_loop_nest(g) - type(gen_state):: g - integer:: nloops - logical:: blocked - integer:: i,n - - if(g_loop_active(g)) return - - select case(g%lstack(g%lthis)%loop_mode) - case(loop_is_none) - return - case(loop_is_contig) - call out_str(g,'DO I') - call out_idx(g,g%lthis) - call out_str(g,'=1,N') - call out_idx(g,g%lthis) - call out_new_line(g) - nloops=1 - case(loop_is_nested) - call gen_nested_loop(g,g%lstack(g%lthis)%loop_par,nloops) - case default - call pm_panic('gen_loop_nest') - end select - g%lstack(g%lthis)%loop_active=.true. - g%lstack(g%lthis)%nloops=nloops - g%last_ve=0 - end subroutine gen_loop_nest - - - !============================================================ - ! Generate loops described by variable v - ! -- v is a grouped tuple ( vdesc , dimension_sizes , blocking ) - ! -- vdesc is a grouped tuple of vdim - ! -- each vdim is either a grouped tuple of sequence parameters - ! or an array - ! Returns number of loops opened in nloops - !============================================================ - subroutine gen_nested_loop(g,v,nloops) - type(gen_state):: g - integer,intent(in):: v - integer,intent(out):: nloops - integer:: i,ndim,vdesc,vdim,vblock,vsize - if(g_kind(g,v)/=v_is_group) call pm_panic('nested loop var not a group') - vdesc=g_ptr(g,v,1) - if(g_kind(g,v)/=v_is_group) call pm_panic('nested loop desc var not a group') - ndim=g_v1(g,vdesc) - nloops=0 - if(g_type(g,g_ptr(g,v,3))==pm_null) then - ! Non-blocked - do i=ndim,1,-1 - vdim=g_ptr(g,vdesc,i) - if(g_kind(g,vdim)==v_is_group) then - if(g_v2(g,vdim)==v_is_struct) then - select case(g_v1(g,vdim)) - case(1) - ! single point - call out_simple(g,'I$N_$M=$I+1',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - nloops=nloops+1 - case(2) - ! range - call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_new_line(g) - nloops=nloops+1 - case(3) - ! strided range - call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - nloops=nloops+1 - case(5) - ! blocked seq - call out_simple_part(g,'DO I$N__$M=($I)-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,5),0) - call out_str(g,',(') - call out_arg(g,g_ptr(g,vdim,2),0) - call out_str(g,'),') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple_part(g,'MIN(I$N__$M+($I)-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,')') - call out_new_line(g) - nloops=nloops+2 - end select - else - call out_simple(g,'DO I$N__$M=1,SIZE($I)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - endif - else - call out_simple(g,'DO I$N__$M=1,SIZE($I%E1)',& - n=i,m=g%lthis,x=vdim) - call out_simple(g,'I$N_$M=$I%E1(I$N__$M)',& - n=i,m=g%lthis,x=vdim) - endif - enddo - elseif(g_v1(g,v)==3) then - ! Post blocking - vblock=g_ptr(g,v,3) - - ! Outer loop - do i=ndim,1,-1 - vdim=g_ptr(g,vdesc,i) - if(g_kind(g,vdim)==v_is_group) then - if(g_v2(g,vdim)==v_is_struct) then - select case(g_v1(g,vdim)) - case(1) - ! single point - call out_simple(g,'I$N_$M=$I+1',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - nloops=nloops+1 - case(2) - ! range - call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_simple_part(g,',$I%E$N',x=vblock,n=i) - call out_new_line(g) - nloops=nloops+1 - case(3) - ! strided range - call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_simple_part(g,'*$I%E$N',x=vblock,n=i) - call out_new_line(g) - nloops=nloops+1 - case(5) - ! blocked seq - call out_simple_part(g,'DO I$N__$M=$I-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,5),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - call out_simple_part(g,'IMAX$N__$M=MIN(I$N__$M+$I-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_line(g,')') - call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),IMAX$N__$M',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple(g,',$I%E$N',x=vblock,n=i) - nloops=nloops+2 - end select - else - ! Arrays (split) - call out_simple_part(g,'DO I$N___$M=1,SIZE($I),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple(g,',$I%E$N',x=vblock,n=i) - endif - else - ! Array - call out_simple_part(g,'DO I$N___$M=1,SIZE($I%E1),',& - n=i,m=g%lthis,x=vdim) - call out_simple(g,',$I%E$N',x=vblock,n=i) - endif - enddo - - ! Loop over block - do i=ndim,1,-1 - vdim=g_ptr(g,vdesc,i) - if(g_kind(g,vdim)==v_is_group) then - if(g_v2(g,vdim)==v_is_struct) then - select case(g_v1(g,vdim)) - case(1) - ! single point - continue - case(2) - ! range - call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,')') - call out_new_line(g) - nloops=nloops+1 - case(3) - ! strided range - call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N*',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,3),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,2),0) - call out_str(g,'),') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - nloops=nloops+1 - case(5) - ! blocked seq - call out_simple(g,'DO I$N_$M=I$N__$M,MIN(IMAX$N__$M,I$N__$M+$I%E$N)',& - n=i,m=g%lthis,x=vblock) - nloops=nloops+1 - end select - else - ! Array (split) - call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,1),0) - call out_line(g,'))') - call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - endif - else - ! Array - call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,1),0) - call out_line(g,'%E1))') - call out_simple(g,'I$N_$M=$I%E1(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - endif - enddo - else - if(g_kind(g,v)==v_is_storageless) then - return - else - call pm_panic('Bad nested loop descriptor') - endif - endif - - ! Calculate combined index - vsize=g_ptr(g,v,2) - call out_char_idx(g,'I',g%lthis) - call out_str(g,'=1+') - call out_char_idx(g,'I',1) - call out_char_idx(g,'_',g%lthis) - do i=2,ndim - call out_char(g,'+') - call out_arg(g,g_ptr(g,vsize,i-1),0) - call out_str(g,'*(I') - call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) - enddo - do i=2,ndim - call out_char(g,')') - enddo - call out_new_line(g) - - end subroutine gen_nested_loop - - - !============================================================ - ! Close all active loops - !============================================================ - subroutine gen_close_loops(g) - type(gen_state):: g - integer:: i - if(g_loop_active(g)) then - do i=1,g%lstack(g%lthis)%nloops - call out_line(g,'ENDDO') - enddo - g%lstack(g%lthis)%loop_active=.false. - g%lstack(g%lthis)%nloops=0 - endif - end subroutine gen_close_loops - - !============================================================ - ! Generate nested if statements to - ! apply masking - !============================================================ - subroutine gen_if_nest(g,ve1,ve2) - type(gen_state):: g - integer,intent(in):: ve1,ve2 - integer,dimension(max_par_depth*2)::stack - integer:: start1,end1 - integer:: start2,end2 - integer:: top,i,vevar - logical:: have_else,cove - top=0 - have_else=.false. - if(ve1>0.and.ve2>0) then - call stack_all(ve1,top,start1,end1) - call stack_all(ve2,top,start2,end2) - do while(stack(end1)==stack(end2)) - end1=end1-1 - end2=end2-1 - if(end1<1.or.end2<1) exit - enddo - if(end1>0.and.end2>0) then - if(g_v2(g,stack(end1))==stack(end2)) then - cove=g_kind(g,stack(end1))==v_is_cove - vevar=stack(merge(end2,end1,cove)) - have_else=g_gflags_clear(g,vevar,var_is_else_disabled) - if(have_else) then - call g_set_gflags(g,vevar,var_is_else_disabled) - else - call g_clear_gflags(g,vevar,var_is_else_disabled) - endif - endif - if(have_else) then - end1=end1-1 - end2=end2-1 - endif - endif - else - if(ve1>0) then - call stack_all(ve1,top,start1,end1) - else - start1=2 - end1=1 - endif - if(ve2>0) then - call stack_all(ve2,top,start2,end2) - else - start2=2 - end2=1 - endif - endif - do i=start1,end1 - call out_line(g,'ENDIF') - enddo - if(have_else) then - call out_line(g,'ELSE') - endif - do i=end2,start2,-1 - call out_str(g,'IF(') - if(g_kind(g,stack(i))==v_is_cove) then - call out_str(g,'.NOT.(') - call out_arg(g,stack(i),0) - call out_char(g,')') - call g_clear_gflags(g,g_v2(g,stack(i)),var_is_else_disabled) - else - call out_arg(g,stack(i),0) - call g_clear_gflags(g,stack(i),var_is_else_disabled) - endif - call out_line(g,') THEN') - enddo - contains - - subroutine stack_all(ve,top,istart,iend) - integer,intent(in):: ve - integer,intent(inout):: top - integer,intent(out):: istart,iend - integer:: parent - call push(top,ve) - istart=top - parent=g_v1(g,ve) - do while(parent/=0) - call push(top,parent) - parent=g_v1(g,parent) - enddo - iend=top - end subroutine stack_all - - subroutine push(top,ve) - integer,intent(inout):: top - integer,intent(in):: ve - top=top+1 - if(top>max_par_depth*2) & - call pm_panic('Program too complex (nested if)') - stack(top)=ve - end subroutine push - - end subroutine gen_if_nest - - !============================================================ - ! Close currently open ifs in this par scope - !============================================================ - subroutine gen_close_ifs(g,last) - type(gen_state):: g - integer,intent(in):: last - integer:: i - - i=g%last_ve - !write(*,*) 'LAST>>',i,last,g%last_ve - do while(i/=last.and.i/=0) - if(debug_g) write(*,*) 'FINISH>',i,g_kind(g,i),g_v1(g,i),g_v2(g,i) - i=g_v1(g,i) - call out_line(g,'ENDIF') - enddo - g%last_ve=0 - end subroutine gen_close_ifs - - !============================================================ - ! Generate code for IF( any active strand ) THEN - !============================================================ - subroutine gen_active_check_start(g,l) - type(gen_state):: g - integer,intent(in):: l - integer:: ve - ve=g%codes(l+comp_op_arg0) - call gen_stacked_ve(g,l,ve) - call gen_loop(g,l,.true.) - if(ve/=0.and.ve/=shared_op_flag) then - if(g_is_a_vect(g,ve)) then - call out_simple(g,'IF(ANY($A))THEN',x=ve) - else - call out_simple(g,'IF($A)THEN',x=ve) - endif - endif - end subroutine gen_active_check_start - - !============================================================ - ! Generate code to close IF( any active strand ) THEN - !============================================================ - subroutine gen_active_check_end(g,l) - type(gen_state):: g - integer,intent(in):: l - integer:: ve - ve=g%codes(l+comp_op_arg0) - if(ve/=0.and.ve/=shared_op_flag) then - call out_line(g,'ENDIF !active check') - endif - end subroutine gen_active_check_end - - !============================================================ - ! Generate code to combine stacked masks (ve) - ! into single logical vector with all elements - ! fully defined (nested ve only have valid - ! values only for strands that were active - ! when they were created) - ! - ! - Assigned to vout if present - ! - Otherwise change in place if necessary - !============================================================ - subroutine gen_stacked_ve(g,l,v,vout) - type(gen_state):: g - integer,intent(in):: l,v - integer,intent(in),optional:: vout - integer:: parent,arg_flags - logical:: stacked_already - if(v==shared_op_flag) return - if(v==0) then - if(present(vout)) then - if(g_loop_active(g)) then - call out_arg(g,vout,0) - else - call out_arg(g,vout,arg_no_index) - endif - call out_line(g,'=.TRUE.') - endif - return - else - parent=g_v1(g,v) - if(parent==0.and..not.present(vout)) return - endif - stacked_already=g_gflags_set(g,v,var_is_stacked_ve) - if(stacked_already.and..not.present(vout)) return - if(g_loop_active(g)) then - call gen_close_ifs(g,0) - arg_flags=0 - else - arg_flags=arg_no_index - endif - if(present(vout)) then - call out_arg(g,vout,arg_flags) - else - call out_arg(g,v,arg_flags) - endif - call out_char(g,'=') - call out_arg(g,v,arg_flags) - if(.not.stacked_already) then - do while(parent/=0) - call out_str(g,'.AND.') - call out_arg(g,parent,arg_flags) - parent=g_v1(g,parent) - end do - endif - call out_str(g,' ! Stacked ve') - call out_new_line(g) - call g_set_gflags(g,v,var_is_stacked_ve) - end subroutine gen_stacked_ve - - !============================================================ - ! Generate code to allocate a vector variable - !============================================================ - subroutine gen_vect_alloc(g) - type(gen_state):: g - integer:: v - v=g%lstack(g%lthis)%varlist - do while(v>0) - if(g_var_at_index_is_a_vect(g,v).and.& - iand(g%vardata(v)%flags,v_is_result)==0.and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then - call out_str(g,'IF(ALLOCATED(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_str(g,')) DEALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_line(g,')') - call out_str(g,'ALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_str(g,'(N') - call out_idx(g,g%lthis) - if(iand(g%vardata(v)%flags,v_is_ve+v_is_cove)/=0) then - call out_str(g,'),SOURCE=.FALSE.)') - else - call out_line(g,'))') - endif - endif - v=g%vardata(v)%link - enddo - end subroutine gen_vect_alloc - - !============================================================ - ! Generate code to deallocate a vector variable - !============================================================ - subroutine gen_vect_dealloc(g) - type(gen_state):: g - integer:: v,outer - v=g%lstack(g%lthis)%varlist - do while(v>0) - if(g_var_at_index_is_a_vect(g,v).and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then - outer=g%vardata(v)%outer_lthis - if(outer/=g%vardata(v)%lthis) then - g%vardata(v)%elink=g%lstack(outer)%defer_free - g%lstack(outer)%defer_free=v - else - call out_str(g,'DEALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_line(g,')') - endif - endif - v=g%vardata(v)%link - enddo - v=g%lstack(g%lthis)%defer_free - do while(v>0) - call out_str(g,'DEALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_line(g,')') - v=g%vardata(v)%elink - enddo - end subroutine gen_vect_dealloc - - - !************************************************************* - ! COMMUNICATION INSTRINSICS - !************************************************************* - - !============================================================ - ! Send messages to multiple other nodes and service - ! Coordinate using non-blocking barrier - ! Arg list: ve block internal-block new-p new-v new-w v w p i - !============================================================ - subroutine gen_mpi_remote_call(g,l,issend) - type(gen_state):: g - integer,intent(in):: l - logical,intent(in):: issend - integer:: a,ve,v,lthis - a=l+comp_op_arg0 - ve=g%codes(a) - call out_line(g,'PM__REQUEST=3-PM__REQUEST') - call out_simple(g,'I$N=1',n=g%lthis) - if(.not.issend) then - v=g%codes(a+6) - endif - call out_line(g,'NNODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NNODE') - call out_line(g,'JTHIS_NODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE') - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - if(ve==0) then - call out_simple(g,'NTOT=SIZE($#7,KIND=PM__LN)',l) - else - call out_simple(g,'NTOT=COUNT($#0)',l) - endif - call out_line(g,'IF(NTOT.GT.0) THEN') - call out_line(g,'ALLOCATE(RSTART%P(0:NNODE))') - call out_line(g,'NXSIZE=MIN(PM__EXCHANGE_BLOCK,NTOT)') - call out_line(g,'ALLOCATE(RFROM%P(NXSIZE))') - if(ve/=0) call out_line(g,'IBG=1') - call out_line(g,'DO ISTART=1,NTOT,PM__EXCHANGE_BLOCK') - call out_line(g,'IFINISH=MIN(ISTART+PM__EXCHANGE_BLOCK-1,NTOT)') - call out_line(g,'NTRANS=IFINISH-ISTART+1') - call out_line(g,'RSTART%P(NNODE)=NTRANS+1') - if(ve==0) then - call out_simple(g,'CALL PM__COLLATE_MESSAGES($#7,ISTART,NTRANS,NNODE,RSTART%P,RFROM%P)',l) - else - call out_simple(g,'CALL PM__COLLATE_MESSAGES_MASKED($#7,COUNT($#0,KIND=PM__LN),NNODE,RSTART%P,RFROM%P,$#0,IBG)',l) - endif - call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& - 'JCOMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - call out_line(g,'DO JNODEBLK=0,NNODE-1,PM__NODE_BLOCK') - call out_line(g,'DO JNODE=JNODEBLK,MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)') - call out_line(g,'IF(JNODE.EQ.JTHIS_NODE.OR.RSTART%P(JNODE).EQ.RSTART%P(JNODE+1)) CYCLE') - if(issend) then - call gen_mpi_send_part(g,g%codes(a+8),'PM__EXTRA_REQ_TAG','ISEND','RFROM%P',& - 'RSTART%P(JNODE)','RSTART%P(JNODE+1)-1',mode_vect) - else - call gen_mpi_recv_part(g,g%codes(a+5),'PM__DATA_TAG','IRECV',.false.,'RFROM%P',& - 'RSTART%P(JNODE)','RSTART%P(JNODE+1)-1',mode_vect) - endif - call gen_mpi_send_part(g,g%codes(a+6),'PM__EXTRA_REQ_TAG','ISEND','RFROM%P','RSTART%P(JNODE)',& - 'RSTART%P(JNODE+1)-1',mode_vect) - call out_line(g,'ENDDO') - call out_line(g,'ALLOCATE(RSBUFFER%P(JNODEBLK:MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)))') - call out_line(g,'DO JNODE=JNODEBLK,MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)') - call out_line(g,'IF(JNODE.EQ.JTHIS_NODE.OR.RSTART%P(JNODE).EQ.RSTART%P(JNODE+1)) CYCLE') - call out_line(g,'RSBUFFER%P(JNODE)=RSTART%P(JNODE+1)-RSTART%P(JNODE)') - call out_line(g,'CALL MPI_ISSEND(RSBUFFER%P(JNODE),1,MPI_AINT,JNODE,PM__REQUEST,JCOMM,'//& - 'JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - call out_line(g,'ENDDO') - - call gen_internal_server_block(g,l,'RFROM%P(IX)+1','RSTART%P(JTHIS_NODE)','RSTART%P(JTHIS_NODE+1)-1') - - call out_line(g,'JCOMPLETE=0') - call out_line(g,'DO WHILE(JCOMPLETE.LT.PM__MESSAGE_TOP-1)') - call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') - call out_line(g,'IF(JRQ.EQ.1)THEN') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) - call out_line(g,'ELSE') - call out_line(g,'JCOMPLETE=JCOMPLETE+1') - call out_line(g,'IF(JCOMPLETE.LT.PM__MESSAGE_TOP)THEN') - call out_line(g,'PM__MESSAGE_STACK(JRQ)=MPI_MESSAGE_NULL') - call out_line(g,'ELSE') - call out_line(g,'EXIT') - call out_line(g,'ENDIF') - call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - if(.not.issend) then - call out_line(g,'DO JNODE=JNODEBLK,MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)') - call out_line(g,'IF(JNODE.EQ.JTHIS_NODE.OR.RSTART%P(JNODE).EQ.RSTART%P(JNODE+1)) CYCLE') - call gen_mpi_recv_part(g,g%codes(a+5),& - 'PM__DATA_TAG','RECV',.true.,'RFROM%P','RSTART%P(JNODE)','RSTART%P(JNODE+1)-1',& - mode_vect) - call out_line(g,'ENDDO') - endif - call out_line(g,'JMESS=PM__MESSAGE_STACK(1)') - call out_line(g,'DEALLOCATE(RSBUFFER%P)') - call out_line(g,'CALL PM__TIDY_MESSAGES()') - call out_line(g,'ENDDO') - call out_line(g,'ENDDO') - call out_line(g,'ELSE') - call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& - 'JCOMM,JMESS,JERRNO)') - call out_line(g,'ENDIF') - call out_line(g,'IF(NTOT.GT.0) DEALLOCATE(RSTART%P,RFROM%P)') - - call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') - call out_line(g,'CALL MPI_IBARRIER(JCOMM,PM__MESSAGE_STACK(2),JERRNO)') - call out_line(g,'PM__MESSAGE_TOP=2') - call out_line(g,'JCOMPLETE=0') - call out_line(g,'DO') - call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') - call out_line(g,'IF(JRQ==1)THEN') - call gen_server_block(g,l,issend,1,lthis) - call out_line(g,'ELSE') - call out_line(g,'IF(JRQ.EQ.2)THEN') - call out_line(g,'CALL MPI_CANCEL(PM__MESSAGE_STACK(1),JERRNO)') - call out_line(g,'CALL MPI_WAIT(PM__MESSAGE_STACK(1),PM__STAT,JERRNO)') - call out_line(g,'IF(PM__MESSAGE_TOP.EQ.2)EXIT') - call out_line(g,'ENDIF') - call out_line(g,'JCOMPLETE=JCOMPLETE+1') - call out_line(g,'PM__MESSAGE_STACK(JRQ)=MPI_MESSAGE_NULL') - call out_line(g,'IF(JCOMPLETE.GE.PM__MESSAGE_TOP-1)EXIT') - call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - call out_line(g,'CALL PM__TIDY_MESSAGES()') - - end subroutine gen_mpi_remote_call - - ! ============================================================= - ! Send messages to single (shared- known) node and service - ! Arg list: ve block internal-block new-v new-w v w p i - ! ========================================================== - subroutine gen_mpi_collect_call(g,l,issend) - type(gen_state):: g - integer,intent(in):: l - logical,intent(in):: issend - integer:: a,ve,v,lthis - a=l+comp_op_arg0 - ve=g%codes(a) - if(.not.issend) then - v=g%codes(a+6) - endif - if(ve==0) then - call out_simple(g,'NTOT=N$N',l,n=g%lthis) - else - call out_simple(g,'NTOT=COUNT($#0)',l) - endif - call out_line(g,'NNODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NNODE') - call out_line(g,'JTHIS_NODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE') - call out_line(g,'JROOT_NODE=PM__NODE_FRAME(PM__NODE_DEPTH)%ROOT_NODE') - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_simple(g,'JNODE=$7',l) - call out_line(g,'IF(JNODE.NE.JROOT_NODE)THEN') - if(ve>0) call out_simple(g,'RFROM%P=PM__ACTIVE_CELLS($A)',x=ve) - call out_line(g,'QXBUFFER%P(1)=PM__EXCHANGE_BLOCK') - call out_line(g,'DO IXBLK=0,NTOT-1,PM__EXCHANGE_BLOCK') - call out_line(g,'NXSIZE=MIN(PM__EXCHANGE_BLOCK,NTOT-IXBLK)') - if(ve>0) then - if(issend) then - call gen_mpi_send_part(g,g%codes(a+8),& - 'PM__EXTRA_REQ_TAG','ISEND','RFROM%P','IXBLK','IXBLK+NXSIZE-1',mode_vect) - else - call gen_mpi_recv_part(g,g%codes(a+5),& - 'PM__EXTRA_REQ_TAG','IRECV',.false.,'RFROM%P','IXBLK','IXBLK+NXSIZE-1',mode_vect) - endif - call gen_mpi_send_part(g,g%codes(a+6),& - 'PM__EXTRA_REQ_TAG','ISEND','RFROM%P','IXBLK','IXBLK+NXSIZE-1',mode_vect) - else - if(issend) then - call gen_mpi_send(g,g%codes(a+8),& - 'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - else - call gen_mpi_recv(g,g%codes(a+5),& - 'PM__EXTRA_REQ_TAG','IRECV',mode_vect,.false.) - endif - call gen_mpi_send(g,g%codes(a+6),& - 'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - endif - call out_line(g,'IF(NXSIZE.EQ.NTOT-IXBLK)THEN') - call out_line(g,'QSBUFFER%P(1)=-NXSIZE') - call out_simple(g,'CALL MPI_ISEND(QSBUFFER%P,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)',l) - call out_line(g,'ELSE') - call out_simple(g,'CALL MPI_ISEND(QXBUFFER%P,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)',l) - call out_line(g,'ENDIF') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - if(.not.issend) then - if(ve>0) then - call gen_mpi_recv_part(g,g%codes(a+6),& - 'PM__DATA_TAG','RECV',.true.,'RFROM%P','IX','IX+NXSIZE-1',0) - else - call gen_mpi_recv(g,g%codes(a+5),& - 'PM__EXTRA_REQ_TAG','IRECV',mode_vect,.true.) - endif - endif - call out_line(g,'CALL PM__COMPLETE_MESSAGES') - call out_line(g,'ENDDO') - call out_line(g,'ELSE') - call out_line(g,'IF(NNODE.GT.1) THEN') - call out_line(g,& - 'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - call out_line(g,'ENDIF') - if(ve>0) then - call gen_internal_server_block(g,l,'RFROM%P(IX)','1','SIZE(RFROM%P)') - else - call gen_internal_server_block(g,l,'IX','1','NTOT') - endif - - call out_line(g,'JCOMPLETE=0') - call out_line(g,'DO WHILE(JCOMPLETE.LT.NNODE-1)') - call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') - call out_line(g,'IF(JRQ.EQ.1)THEN') - call out_line(g,'JNODE=PM__STAT(MPI_SOURCE)') - call out_line(g,'NSIZE=QRBUFFER%P(1)') - call out_line(g,'IF(NSIZE.LT.0)THEN') - call out_line(g,'NSIZE=-NSIZE') - call out_line(g,'JCOMPLETE=JCOMPLETE+1') - call out_line(g,'ENDIF') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) - - call out_line(g,'IF(JCOMPLETE.EQ.NNODE-1)EXIT') - call out_line(g,& - 'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') - call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - - call out_line(g,'CALL PM__TIDY_MESSAGES()') - - call out_line(g,'ENDIF') - - end subroutine gen_mpi_collect_call - - !============================================================ - ! Code service of inter-node message - ! Arg list: ve block [ internal-block ] new-v new-w v w p i - ! [ internal-block ] present if extra_arg=1 (instead of 0) - !============================================================ - subroutine gen_server_block(g,l,issend,extra_arg,lthis) - type(gen_state):: g - integer,intent(in):: l,extra_arg - logical,intent(in):: issend - integer,intent(inout):: lthis - integer:: a,save_lthis,save_last_ve,ll - - a=l+comp_op_arg0+extra_arg - save_lthis=g%lthis - if(lthis<0) then - g%ltop=g%ltop+1 - g%lthis=g%ltop - lthis=g%lthis - else - g%lthis=lthis - endif - g%lstack(g%lthis)%nloops=1 - save_last_ve=g%last_ve - g%last_ve=0 - - if(pm_opts%ftn_annotate) then - call out_simple(g,'! BLOCK $N (server)',n=g%lthis) - endif - - call out_simple(g,'N$N=ABS(QRBUFFER%P(1))',n=g%lthis) - call out_line(g,'NA0=1') - - call gen_vect_alloc(g) - - call out_line(g,'JNODE=PM__STAT(MPI_SOURCE)') - if(issend) then - call gen_mpi_recv(g,g%codes(a+4),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - endif - call gen_mpi_recv(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - - if(issend) then - call out_line(g,& - 'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%IS_SHARED.AND.JTHIS_NODE.EQ.JROOT_NODE)THEN') - call out_line(g,'DO JNODE2=1,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NNODE-1') - call out_line(g,'JNODE=PM__GET_SHARED(JNODE2)') - call gen_mpi_send(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call gen_mpi_send(g,g%codes(a+4),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call out_line(g,'ENDDO') - call out_line(g,'ENDIF') - endif - - call out_simple(g,'DO I$N=1,N$N ! Start of server block',n=g%lthis) - g%lstack(g%lthis)%loop_active=.true. - ll=g%codes(a+1-extra_arg) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call gen_if_nest(g,g%last_ve,0) - - call out_line(g,'ENDDO !End of server block') - g%lstack(g%lthis)%loop_active=.false. - g%last_ve=0 - - if(.not.issend) then - call gen_mpi_send(g,g%codes(a+7),'PM__DATA_TAG','RSEND',mode_vect) - endif - - call gen_vect_dealloc(g) - - g%last_ve=save_last_ve - g%lthis=save_lthis - - call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& - 'JCOMM,JMESS,JERRNO)') - call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') - - if(pm_opts%ftn_annotate) then - call out_simple(g,'! END BLOCK $N (server)',n=g%lthis) - endif - end subroutine gen_server_block - - !============================================================ - ! Code to run block servicing intra-node messages - ! Arg list: ve block internal-block new-v new-w v w p i - ! Assumes aliasing of arguments: - ! new-v <-> v - ! new-w <-> w - !============================================================ - subroutine gen_internal_server_block(g,l,vd,vs,ve) - type(gen_state):: g - integer,intent(in):: l - character(len=*),intent(in):: vd,vs,ve - integer:: ll,a - a=l+comp_op_arg0 - call out_line(g,'DO IX='//vs//','//ve) - call out_char_idx(g,'I',g%lthis) - call out_char(g,'=') - call out_line(g,vd) - g%lstack(g%lthis)%nloops=1 - g%lstack(g%lthis)%loop_active=.true. - ll=g%codes(a+2) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call out_line(g,'ENDDO') - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_active=.false. - g%last_ve=0 - end subroutine gen_internal_server_block - - !============================================================ - ! Broadcast message to all nodes in group and service - ! Arg list: ve block new-v new-w v w p i - !============================================================ - subroutine gen_mpi_bcast_call(g,l) - type(gen_state),intent(inout):: g - integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve - a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) - call out_simple(g,'JNODE=$6',l) - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=N$N',n=g%lthis) - call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - save_last_ve=g%last_ve - g%last_ve=0 - - call out_simple(g,'N$N=NA',n=g%lthis) - call out_line(g,'NA0=1') - - call gen_vect_alloc(g) - - call gen_pack(g,g%codes(a+2),g%codes(a+4),0) - call gen_pack(g,g%codes(a+3),g%codes(a+5),0) - - - call gen_mpi_bcast(g,g%codes(a+2)) - call gen_mpi_bcast(g,g%codes(a+3)) - - ll=g%codes(a+1) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - - call gen_loop(g,l,.true.) - - call gen_vect_dealloc(g) - - g%last_ve=save_last_ve - g%lthis=save_lthis - - end subroutine gen_mpi_bcast_call - - !============================================================================ - ! Broadcast message to all nodes in group and service (conditional context) - ! Arg list: ve block new-v new-w v w p i - !============================================================================ - subroutine gen_mpi_masked_bcast_call(g,l) - type(gen_state),intent(inout):: g - integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve - a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) - call out_simple(g,'JNODE=$6',l) - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=COUNT($#0)',l) - call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - save_last_ve=g%last_ve - g%last_ve=0 - - call out_simple(g,'N$N=NA',n=g%lthis) - - call gen_vect_alloc(g) - - call out_line(g,'IF(NA.GT.0) THEN') - - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE)THEN') - call gen_pack(g,g%codes(a+2),g%codes(a+4),g%codes(a)) - call gen_pack(g,g%codes(a+3),g%codes(a+5),g%codes(a)) - call out_line(g,'ENDIF') - - call gen_mpi_bcast(g,g%codes(a+2)) - call gen_mpi_bcast(g,g%codes(a+3)) - - ll=g%codes(a+1) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - - call gen_loop(g,l,.true.) - - call out_line(g,'ENDIF') - - call gen_vect_dealloc(g) - - g%last_ve=save_last_ve - g%lthis=save_lthis - - end subroutine gen_mpi_masked_bcast_call - - !============================================================ - ! Code mpi_send, mpi_isend, mpi_issend ... - ! node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_send(g,v,tag,s,mode,comm) - type(gen_state):: g - integer,intent(in):: v - integer,intent(in):: mode - character(len=*),intent(in):: tag,s - character(len=*),intent(in),optional:: comm - integer:: k,k2,i,tno,a - logical:: nonblocking - character(len=5):: ibuffer - type(pm_ptr):: tv - !call out_simple(g,'WRITE(*,*) "SEND",$N',n=abs(v)) - nonblocking=s=='ISEND'.or.s=='ISSEND' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_send(g,i,tag,s,mode_vect) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_send(g,g_ptr(g,v,3),tag,s,mode_vect) - endif - elseif(k2==v_is_storageless) then - continue - elseif(k2==v_is_array) then - if(mode==mode_array) then - call gen_mpi_send(g,g_ptr(g,v,1),tag,s,mode_array_vect) - else - ! Split array view - tno=g_type(g,v) - call g_add_packable(g,pack_array_vect,tno) - call out_simple_part(g,'CALL PM__PACKAVEC$N(NA,$A,',& - n=tno,x=g_ptr(g,v,1)) - call out_arg(g,g_ptr(g,v,2),arg_no_index) - call out_line(g,')') - call send_buffer - endif - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_send(g,g_ptr(g,v,i),tag,s,mode) - enddo - endif - case(v_is_basic,v_is_elem,v_is_unit_elem,v_is_sub,v_is_vsub,& - v_is_const,v_is_ctime_const) - call out_str(g,'NA=SIZE(') - call out_comm_var(g,v,mode) - call out_line(g,')') - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call g_add_packable(g,pack_vect,tno) - call out_simple_part(g,'CALL PM__PACKVEC$N(NA,',n=tno) - call out_comm_var(g,v,mode) - call out_line(g,')') - call send_buffer - else - call out_get_mpi_base_type(g,tno) - call out_line(g,'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)') - call out_str(g,'CALL MPI_'//s//'(') - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JERRNO)') - endif - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_send(g,g_v1(g,v),tag,s,merge(mode_vect,mode,k==v_is_chan_vect),comm) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_send') - end select - contains - subroutine send_buffer - if(s=='RSEND') then - call out_str(g,'CALL PM__ISEND_BUFFER(JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - call out_str(g,'CALL MPI_RSEND(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JERROR)') - else - call out_line(g,'CALL PM__'//s//'_BUFFER(JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - if(nonblocking) then - call out_str(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_str(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - endif - endif - end subroutine send_buffer - end subroutine gen_mpi_send - - !============================================================ - ! Output vector component of variable v - mode governs - ! whether this is grouped array - !============================================================ - subroutine out_comm_var(g,v,mode) - type(gen_state):: g - integer,intent(in):: v - integer,intent(in):: mode - !write(*,*) 'v is ',v,g_kind(g,v) - !write(*,*) 'SENDING OUT COMM',mode,g%lthis,g_lthis(g,v) - call out_arg(g,v,merge(0,arg_no_index,mode==mode_array)) - if(mode==mode_array) then - call out_str(g,'%E1%P') - elseif(mode==mode_array_vect) then - call out_str(g,'%P') - endif - end subroutine out_comm_var - - !============================================================ - ! If comm string is present then output it, otherwise - ! output the default communicator for this context - !============================================================ - subroutine out_comm_str(g,comm) - type(gen_state):: g - character(len=*),optional:: comm - if(present(comm)) then - call out_str(g,comm) - else - call out_str(g,'PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - endif - end subroutine out_comm_str - - !============================================================ - ! Code mpi_irecv mpi_isrecv ... - ! Node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_recv(g,v,tag,s,mode,rest,comm) - type(gen_state):: g - integer,intent(in):: v - integer,intent(in):: mode - character(len=*),intent(in):: tag,s - character,intent(in),optional:: comm - logical,intent(in):: rest - integer:: k,k2,i,tno,a - logical:: nonblocking,nontrivial - character(len=5):: ibuffer - nonblocking=s=='IRECV' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_recv(g,i,tag,s,mode,rest,comm) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_recv(g,g_ptr(g,v,3),tag,s,mode,rest,comm) - endif - elseif(k2==v_is_storageless) then - continue - elseif(k2==v_is_array) then - if(mode/=mode_array) call pm_panic('recv to split array') - call gen_mpi_recv(g,g_ptr(g,v,1),tag,s,mode_array_vect,rest,comm) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_recv(g,g_ptr(g,v,i),tag,s,mode,rest,comm) - enddo - endif - case(v_is_basic) - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call out_str(g,'NA=SIZE(') - call out_comm_var(g,v,mode) - call out_line(g,')') - if(nonblocking) then - call out_line(g,'CALL MPI_IRECV(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - if(.not.rest) then - call out_str(g,'CALL MPI_RECV(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',MPI_STATUS_IGNORE,JERRNO)') - endif - call g_add_packable(g,unpack_vect,tno) - call out_str(g,'CALL PM__RECV_BUFFER(JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - call out_line(g,'PM__BUFFER%SIZEOF=0') - call out_simple_part(g,'CALL PM__UNPACKVEC$N(NA,',n=tno) - call out_comm_var(g,v,mode) - call out_line(g,')') - endif - else - if(.not.rest) then - call out_str(g,'NA=SIZE(') - call out_comm_var(g,v,mode) - call out_line(g,')') - call out_get_mpi_base_type(g,tno) - call out_line(g,'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)') - call out_str(g,'CALL MPI_'//s//'(') - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',MPI_STATUS_IGNORE,JERRNO)') - endif - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_recv(g,g_v1(g,v),tag,s,mode,rest,comm) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_recv') - end select - end subroutine gen_mpi_recv - - !============================================================ - ! Generate code for mpi broadcast - ! node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_bcast(g,v,isshared,array_vect) - type(gen_state),intent(inout):: g - integer,intent(in):: v - logical,intent(in),optional:: isshared,array_vect - integer:: tno - integer:: k,k2,i - logical:: nontrivial,isvec - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - if(debug_g) then - write(*,*) 'DREF>',g_ptr(g,v,1),g_ptr(g,v,2),g_ptr(g,v,3),g_ptr(g,v,4),g_ptr(g,v,5) - endif - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_bcast(g,i,isshared,array_vect) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_bcast(g,g_ptr(g,v,3),isshared,array_vect) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - call gen_mpi_bcast(g,g_ptr(g,v,1),isshared,array_vect=.true.) - call gen_mpi_bcast(g,g_ptr(g,v,2),isshared,array_vect) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_bcast(g,g_ptr(g,v,i),isshared,array_vect) - enddo - endif - case(v_is_basic,v_is_chan_vect) - tno=g_type(g,v) - isvec=g_is_vect(g,v).or.present(array_vect) - if(g_is_complex_type(g,tno)) then - call g_add_packable(g,pack_scalar,tno) - call out_line(g,'CALL PM__NEW_BUFFER') - if(isvec) then - call out_simple(g,'NA=SIZE($A)',x=v) - endif - if(present(isshared)) then - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - else - call out_line(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) THEN') - endif - if(.not.isvec) then - call g_add_packable(g,pack_scalar,tno) - call out_simple(g,'CALL PM__COUNT($I)',x=v) - call out_line(g,'CALL PM__ALLOCATE_BUFFER') - call out_simple(g,'CALL PM__PACK($I)',x=v) - else - call g_add_packable(g,pack_vect,tno) - call out_simple(g,'CALL PM__PACKVEC$N(NA,$A)',n=tno,x=v) - endif - if(present(isshared)) then - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - else - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - endif - if(.not.isvec) then - call out_simple(g,'CALL PM__UNPACK$N($A)',x=v,n=tno) - else - call out_simple(g,'CALL PM__UNPACKVEC$N(NA,$A)',x=v,n=tno) - endif - call out_line(g,'ENDIF') - else - tno=g_type(g,v) - if(.not.isvec) then - call out_line(g,'JN=1') - call out_get_mpi_base_type(g,tno) - call out_line(g,'JTYPE=JBASE') - else - if(present(array_vect)) then - call out_simple(g,'NA=SIZE($A%P)',x=v) - else - call out_simple(g,'NA=SIZE($A)',x=v) - endif - call out_get_mpi_base_type(g,tno) - call out_simple(g,& - 'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)',n=g%lthis) - endif - call out_str(g,'CALL MPI_BCAST(') - call out_arg(g,v,merge(arg_no_index,0,isvec)) - if(present(array_vect)) then - call out_str(g,'%P') - endif - if(present(isshared)) then - call out_line(g,& - ',JN,JTYPE,0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM,JERRNO)') - else - call out_line(g,& - ',JN,JTYPE,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - if(isvec) then - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - endif - endif - case(v_is_alias) - call gen_mpi_bcast(g,g_v1(g,v)) - case default - call pm_panic('problem var in gen_mpi_bcast') - end select - end subroutine gen_mpi_bcast - - !======================================================================== - ! Code mpi_send mpi_isend ... for sub-array defined in disp_var - ! Node must be in JNODE - !======================================================================== - subroutine gen_mpi_send_disp_or_grid(g,v,tag,s,disp_var,mode) - type(gen_state):: g - integer,intent(in):: v,disp_var - character(len=*),intent(in):: tag,s - integer,intent(in),optional:: mode - call gen_mpi_send_part(g,v,tag,s,'$A','1','SIZE($A)',mode,disp_var) - end subroutine gen_mpi_send_disp_or_grid - - !======================================================================== - ! Code mpi_recv mpi_irecv ... for sub-array defined in disp_var - ! Node must be in JNODE - !======================================================================== - subroutine gen_mpi_recv_disp_or_grid(g,v,tag,s,disp_var,mode,rest) - type(gen_state):: g - integer,intent(in):: v,disp_var - character(len=*),intent(in):: tag,s - logical,intent(in):: rest - integer,intent(in):: mode - call gen_mpi_recv_part(g,v,tag,s,rest,'$A','1','SIZE($A)',mode,disp_var) - end subroutine gen_mpi_recv_disp_or_grid - - !======================================================================== - ! Code mpi_isend mpi_issend ... for sub-array - ! - either dv(dv1:dv2) or by displacements defined in dvv - ! Node must be in JNODE - !======================================================================== - recursive subroutine gen_mpi_send_part(g,v,tag,s,dv,dv1,dv2,mode,dvv) - type(gen_state):: g - integer,intent(in):: v,mode - character(len=*),intent(in):: dv,dv1,dv2,tag,s - integer,intent(in),optional:: dvv - integer:: k,k2,i,tno,a - logical:: nonblocking,nontrivial,ok - character(len=5):: ibuffer - !call out_simple(g,'WRITE(*,*) "SEND DISP",$N,$M',n=abs(v),m=mode) - if(debug_g) write(*,*) 'SEND_DISP> v=',v,'s=',trim(s),'k=',g_kind(g,v) - nonblocking=s=='ISEND'.or.s=='ISSEND' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_send_part(g,i,tag,s,dv,dv1,dv2,mode,dvv) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_send_part(g,g_ptr(g,v,3),tag,s,dv,dv1,dv2,mode,dvv) - endif - elseif(k2<0) then - continue - elseif(k2==v_is_array) then - if(mode==mode_array) then - call gen_mpi_send_part(g,g_ptr(g,v,1),tag,s,dv,dv1,dv2,mode_array_vect,dvv) - else - call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) - tno=g_type(g,v) - call g_add_packable(g,pack_array_vect_disp,tno) - call out_simple_part(g,'CALL PM__PACKADVEC$N(NA,$A,',& - n=tno,x=g_ptr(g,v,1)) - call out_arg(g,g_ptr(g,v,2),arg_no_index) - call out_simple(g,','//dv//'('//dv1//':'//dv2//'))',x=dvv) - call out_line(g,'CALL PM__'//s//'_BUFFER(JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - endif - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_send_part(g,g_ptr(g,v,i),tag,s,dv,dv1,dv2,mode,dvv) - enddo - endif - case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,& - v_is_unit_elem,v_is_const,v_is_ctime_const) - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) - if(nonblocking) then - call out_line(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//& - tag//',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_line(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//& - tag//',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - call g_add_packable(g,pack_vect_disp,tno) - call out_simple_part(g,'CALL PM__PACKDVEC$N(NA,',n=tno) - call out_comm_var(g,v,mode) - call out_simple(g,','//dv//'('//dv1//':'//dv2//'))',x=dvv) - call out_line(g,'CALL PM__'//s//'_BUFFER(JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - elseif(tno>=pm_int) then - call make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - call out_str(g,'CALL MPI_'//s//'(') - if(debug_g) write(*,*) 'SENDING> v=',v,nonblocking,mode - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_line(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_line(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_send_part(g,g_v1(g,v),tag,s,dv,dv1,dv2,mode,dvv) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_send_part') - end select - if(debug_g) write(*,*) 'END SEND DISP>',v - end subroutine gen_mpi_send_part - - !============================================================ - ! Code mpi_recv, mpi_irecv - ! - either dv(dv1:dv2) or by displacements defined in dvv - ! Node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_recv_part(g,v,tag,s,rest,dv,dv1,dv2,mode,dvv) - type(gen_state):: g - integer,intent(in):: v,mode - character(len=*),intent(in):: tag,s,dv,dv1,dv2 - integer,intent(in),optional:: dvv - logical,intent(in):: rest - integer:: k,k2,i,tno,a - logical:: nonblocking,ok - character(len=5):: ibuffer - if(debug_g) write(*,*) 'RECV>',v - nonblocking=s=='IRECV' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_recv_part(g,i,tag,s,rest,dv,dv1,dv2,mode,dvv) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_recv_part(g,g_ptr(g,v,3),tag,s,rest,dv,dv1,dv2,mode,dvv) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - if(mode/=mode_array) call pm_panic('recv_disp to split array') - call gen_mpi_recv_part(g,g_ptr(g,v,1),tag,s,rest,dv,dv1,dv2,mode_array_vect,dvv) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_recv_part(g,g_ptr(g,v,i),tag,s,rest,dv,dv1,dv2,mode,dvv) - enddo - endif - case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) - tno=g_type(g,v) - if(mode==mode_array) then - !write(*,*) 'tno=',pm_typ_as_string(g%context,tno) - tno=pm_typ_arg(g%context,tno,1) - endif - if(g_is_complex_type(g,tno)) then - if(nonblocking) then - call out_line(g,'CALL MPI_IRECV(J,0,MPI_INTEGER,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - if(.not.rest) then - call out_line(g,'CALL MPI_RECV(J,0,MPI_INTEGER,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,MPI_STATUS_IGNORE,JERRNO)') - endif - call out_line(g,& - 'CALL PM__RECV_BUFFER(JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - call g_add_packable(g,unpack_vect_disp,tno) - call out_simple_part(g,'CALL PM__UNPACKDVEC$N(',n=tno) - call out_str(g,'('//dv2//')-('//dv1//')+1,') - call out_comm_var(g,v,mode) - call out_simple(g,','//dv//'('//dv1//':'//dv2//'))',x=dvv) - endif - elseif(tno>=pm_int) then - if(.not.rest) then - call make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - call out_str(g,'CALL MPI_'//s//'(') - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_line(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_simple(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,MPI_STATUS_IGNORE,JERRNO)') - endif - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_recv_part(g,g_v1(g,v),tag,s,rest,dv,dv1,dv2,mode,dvv) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_recv_part') - end select - end subroutine gen_mpi_recv_part - - !============================================================ - ! Generate code for mpi broadcast - ! node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_bcast_part(g,v,isshared,dv,dv1,dv2,mode,dvv) - type(gen_state),intent(inout):: g - integer,intent(in):: v,mode - logical,intent(in),optional:: isshared - character(len=*),intent(in):: dv,dv1,dv2 - integer,intent(in),optional:: dvv - integer:: tno - integer:: k,k2,i - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - if(debug_g) then - write(*,*) 'DREF>',g_ptr(g,v,1),g_ptr(g,v,2),g_ptr(g,v,3),g_ptr(g,v,4),g_ptr(g,v,5) - endif - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_bcast_part(g,i,isshared,dv,dv1,dv2,mode,dvv) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_bcast_part(g,g_ptr(g,v,3),isshared,dv,dv1,dv2,mode,dvv) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - call gen_mpi_bcast_part(g,g_ptr(g,v,i),isshared,dv,dv1,dv2,mode_array_vect,dvv) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_bcast_part(g,g_ptr(g,v,i),isshared,dv,dv1,dv2,mode,dvv) - enddo - endif - case(v_is_basic) - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) - call g_add_packable(g,pack_vect_disp,tno) - call g_add_packable(g,unpack_vect_disp,tno) - if(isshared) then - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - else - call out_line(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) THEN') - endif - call out_simple_part(g,'CALL PM__PACKDVEC$N(NA,%A',n=tno,x=v) - call out_simple(g,dv//'('//dv1//':'//dv2//'))',x=dvv) - if(isshared) then - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - else - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - endif - call out_simple_part(g,'CALL PM__UNPACKDVEC$N(NA,%A',n=tno,x=v) - call out_line(g,'ENDIF') - elseif(tno>=pm_int) then - call make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - call out_str(g,'CALL MPI_BCAST(') - call out_arg(g,v,arg_no_index) - - if(isshared) then - call out_line(g,',1,JTYPE,JNODE,'& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM,JERRNO)') - else - call out_simple(g,',1,JTYPE,JNODE,'& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_bcast_part(g,g_v1(g,v),isshared,dv,dv1,dv2,mode,dvv) - case default - call pm_panic('problem var in gen_mpi_bcast_disp') - end select - end subroutine gen_mpi_bcast_part - - !============================================================ - ! Output code to wait on all pending mpi messages - ! implementing op_sync_mess - !============================================================ - subroutine gen_sync_mess(g,l,a,n) - type(gen_state):: g - integer,intent(in):: l,a,n - call gen_sync_reg - call out_line(g,& - 'CALL MPI_WAITALL(PM__MESSAGE_TOP,PM__MESSAGE_STACK,MPI_STATUSES_IGNORE,JERRNO)') - call gen_sync_reg - call out_line(g,'CALL PM__TIDY_MESSAGES()') - contains - subroutine gen_sync_reg - integer:: i,arg - if(n>0) then - call out_line(g,'IF(.NOT.MPI_ASYNC_PROTECTS_NONBLOCKING)THEN') - do i=1,n-1 - arg=g%codes(a+i) - if(g%varindex(arg)==0) cycle - if(g_flags_set(g,arg,v_is_param)) cycle - if(g_kind(g,arg)==v_is_ctime_const) cycle - call out_simple(g,'CALL MPI_F_SYNC_REG($Y)',l,x=i) - enddo - call out_line(g,'ENDIF') - endif - end subroutine gen_sync_reg - end subroutine gen_sync_mess - - - !================================================================ - ! Create MPI datatype to either encode displacements dv(dv1:dv2) - ! or PM grid defined by dvv (if dvv argument present) - !================================================================ - - !!! Change to disp_or_grid type - !!! correct access to tuple - - subroutine make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - type(gen_state):: g - integer,intent(in):: tno,mode - character(len=*),intent(in):: dv,dv1,dv2 - integer,intent(in),optional:: dvv - integer:: grid_tuple,grid_dim,i,j - type(pm_ptr):: tv - if(present(dvv)) then - if(g_kind(g,dvv)==v_is_group) then - grid_tuple=g_ptr(g,dvv,1) - if(pm_debug_checks) then - if(g_kind(g,grid_tuple)/=v_is_group) then - call pm_panic('norm grid not a group') - endif - endif - call out_get_mpi_base_type(g,tno) - call out_line(g,'JTYPE=JBASE') - do i=1,g_v1(g,grid_tuple) - grid_dim=g_ptr(g,grid_tuple,i) - if(g_kind(g,grid_tuple)/=v_is_group) then - call pm_panic('norm grid dim not a group') - endif - if(g_v1(g,grid_dim)==1) then - grid_dim=g_ptr(g,grid_dim,1) - if(g_kind(g,grid_dim)==v_is_group) then - if(g_v2(g,grid_dim)/=v_is_array.and.g_v2(g,grid_dim)/=v_is_var_array) then - call pm_panic('grid dim array not array') - endif - call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A,1_PM__LN,JTYPE_N)',& - x=g_ptr(g,grid_dim,1)) - call out_line(g,'JTYPE=JTYPE_N') - elseif(pm_typ_kind(g%context,g_type(g,grid_dim))==pm_typ_is_array) then - call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A%P,1_PM__LN,JTYPE_N)',& - x=g_ptr(g,grid_dim,1)) - call out_line(g,'JTYPE=JTYPE_N') - endif - else - if(g_v1(g,grid_dim)/=6) then - call pm_panic('grid_dim incorrect number of entries') - endif - call out_str(g,'CALL PM__GET_MPI_SUBRANGE_TYPE(JTYPE,') - tv=pm_typ_vect(g%context,g_type(g,grid_dim)) - do j=1,6 - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),pm_typ_has_storage)/=0) then - call out_arg(g,g_ptr(g,grid_dim,j),0) - call out_char(g,',') - else - call out_const(g,pm_typ_val(g%context,pm_tv_arg(tv,j))) - call out_char(g,',') - endif - enddo - call out_line(g,'JTYPE_N)') - call out_line(g,'JTYPE=JTYPE_N') - endif - enddo - call out_line(g,'CALL MPI_TYPE_COMMIT(JTYPE,JERRNO)') - return - endif - endif - call out_get_mpi_base_type(g,tno) - !write(*,*) dvv,'::','CALL PM__GET_MPI_DISP_TYPE(JBASE,'//dv//'('//dv1//':'//dv2//')' - call out_simple_part(g,'CALL PM__GET_MPI_DISP_TYPE(JBASE,'//dv//'('//dv1//':'//dv2//')',x=dvv) - call out_line(g,',1_PM__LN,JTYPE)') - end subroutine make_disp_mpi_type - - !============================================================ - ! Generate code for - ! v1<-pack(v2,m) where m is logical vector - !============================================================ - recursive subroutine gen_pack(g,v1,v2,m) - type(gen_state),intent(inout):: g - integer,intent(in):: v1,v2,m - integer:: k,k2,i - if(debug_g) write(*,*) 'PACK> v1=',v1,g_kind(g,v1),'v2=',v2,g_kind(g,v2),'m=',m - k=g_kind(g,v1) - k2=g_v2(g,v1) - if(k==v_is_group) then - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v1,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_pack(g,i,g_ptr(g,v2,2),m) - endif - if(k2/=v_is_shared_dref) then - call gen_pack(g,g_ptr(g,v1,3),g_ptr(g,v2,3),m) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - call gen_pack(g,g_ptr(g,v1,1),g_ptr(g,v2,1),m) - call gen_pack(g,g_ptr(g,v1,2),g_ptr(g,v2,2),m) - else - ! Structures/records - do i=1,g_v1(g,v1) - call gen_pack(g,g_ptr(g,v1,i),g_ptr(g,v2,i),m) - enddo - endif - elseif(iand(k2,v_is_poly)/=0) then - call out_line(g,'IX=0') - call out_simple(g,'DO I$N=1,N$N',n=g%lthis) - if(m/=0) call out_simple(g,'IF($I) THEN',x=m) - call out_line(g,'IX=IX+1') - call out_arg(g,v1,arg_ix_index) - call out_char(g,'=') - call out_arg(g,v2,0) - call out_new_line(g) - if(m/=0) call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - else - call out_arg(g,v1,arg_no_index) - if(m==0) then - call out_char(g,'=') - call out_arg(g,v2,arg_wrapped) - call out_str(g,' ! pack - copy') - else - call out_str(g,'=PACK(') - call out_arg(g,v2,arg_wrapped) - call out_char(g,',') - call out_arg(g,m,arg_wrapped) - call out_char(g,')') - endif - call out_new_line(g) - endif - if(debug_g) write(*,*) 'PACKED> v1=',v1 - end subroutine gen_pack - - !*************************************************************** - ! ROUTINES TO (UN)PACK DATA TO A COMMUNICATIONS BUFFER - !*************************************************************** - - subroutine gen_packables(g) - type(gen_state),intent(inout):: g - integer:: i,kind,tno - type(pm_ptr):: key - ! Generate any required COUNT/PACK/UNPACK subroutines - i=1 - do while(i<=pm_set_size(g%context,g%packables)) - key=pm_set_key(g%context,g%packables,int(i,pm_ln)) - kind=key%data%i(key%offset) - tno=key%data%i(key%offset+1) - select case(kind) - case(pack_scalar) - call gen_count_routine(g,tno) - call gen_pack_routine(g,tno) - call gen_unpack_routine(g,tno) - case(pack_vect,pack_vect_disp) - call gen_vect_pack_to_buffer(g,tno,kind/=pack_vect) - case(pack_array_vect,pack_array_vect_disp) - call gen_array_vect_pack_to_buffer(g,tno,kind/=pack_array_vect) - case(unpack_vect,unpack_vect_disp) - call gen_vect_unpack_from_buffer(g,tno,kind/=unpack_vect) - case default - call pm_panic('gen_packables') - end select - i=i+1 - enddo - end subroutine gen_packables - - !==================================================== - ! Flag that we need pack/unpack routines for type tno - ! kind= which routines needed (pack_scalar..) - !==================================================== - recursive subroutine g_add_packable(g,kind,tno) - type(gen_state),intent(inout):: g - integer,intent(in):: kind,tno - integer:: key(2),i - integer(pm_ln):: j - if(tno<=pm_null) return - key(1)=kind - key(2)=tno - j=pm_iset_add(g%context,g%packables,key,2) - end subroutine g_add_packable - - !=============================================== - ! Pack variable v to newly allocated buffer - ! v is a vector length NA - !============================================== - subroutine gen_vect_pack_to_buffer(g,tno,isdisp) - type(gen_state):: g - integer,intent(in):: tno - logical,intent(in):: isdisp - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - call out_new_line(g) - if(isdisp) then - call out_simple(g,'SUBROUTINE PM__PACKDVEC$N(NA,X,D)',n=tno) - else - call out_simple(g,'SUBROUTINE PM__PACKVEC$N(NA,X)',n=tno) - endif - call out_line(g,'INTEGER(PM__LN):: NA') - call out_type(g,tno) - call out_line(g,',DIMENSION(:)::X') - if(isdisp) call out_line(g,'INTEGER(PM__LN),DIMENSION(NA)::D') - call out_line(g,'CALL PM__NEW_BUFFER') - has_depth=.false. - counts=0 - call out_line(g,'NP1=NA') - call precount(g,tno,counts,has_depth) - if(has_depth) then - if(isdisp) then - call out_line(g,'DO IX=1,NA') - call out_line(g,'IP1=D(IX)+1') - else - call out_line(g,'DO IP1=1,NA') - endif - call outcount(g,tno,'X'//'(IP1)',1) - call out_line(g,'ENDDO') - endif - call outaddcount(g,counts,1) - call out_line(g,'CALL PM__ALLOCATE_BUFFER') - call g_add_packable(g,pack_scalar,tno) - if(isdisp) then - call out_line(g,'DO IIX=1,NA') - call out_line(g,'IX=D(IIX)+1') - else - call out_line(g,'DO IX=1,NA') - endif - call out_simple(g,'CALL PM__PACK$N(X(IX))',n=tno) - call out_line(g,'ENDDO') - if(isdisp) then - call out_simple(g,'END SUBROUTINE PM__PACKDVEC$N',n=tno) - else - call out_simple(g,'END SUBROUTINE PM__PACKVEC$N',n=tno) - endif - end subroutine gen_vect_pack_to_buffer - - !=============================================== - ! Pack variable v to newly allocated buffer - ! v is a vector length NA - !============================================== - subroutine gen_vect_unpack_from_buffer(g,tno,isdisp) - type(gen_state):: g - integer,intent(in):: tno - logical,intent(in):: isdisp - call out_new_line(g) - if(isdisp) then - call out_simple(g,'SUBROUTINE PM__UNPACKDVEC$N(NA,X,D)',n=tno) - else - call out_simple(g,'SUBROUTINE PM__UNPACKVEC$N(NA,X)',n=tno) - endif - call out_line(g,'INTEGER(PM__LN):: NA') - call out_type(g,tno) - call out_line(g,',DIMENSION(:):: X') - if(isdisp) then - call out_line(g,'INTEGER(PM__LN),DIMENSION(NA):: D') - endif - call g_add_packable(g,pack_scalar,tno) - if(isdisp) then - call out_line(g,'DO IIX=1,NA') - call out_line(g,'IX=D(IIX)+1') - else - call out_line(g,'DO IX=1,NA') - endif - call out_simple(g,'CALL PM__UNPACK$N(X(IX))',n=tno) - call out_line(g,'ENDDO') - if(isdisp) then - call out_simple(g,'END SUBROUTINE PM__UNPACKDVEC$N',n=tno) - else - call out_simple(g,'END SUBROUTINE PM__UNPACKVEC$N',n=tno) - endif - end subroutine gen_vect_unpack_from_buffer - - - !================================================== - ! Pack split array v1/cv2 to newly allocated buffer - ! v1 and v2 are vectors length NA - !=================================================== - subroutine gen_array_vect_pack_to_buffer(g,tno,isdisp) - type(gen_state):: g - integer,intent(in):: tno - logical:: isdisp - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - type(pm_ptr):: tv - integer:: tno1,tno2 - tv=pm_typ_vect(g%context,tno) - tno1=pm_tv_arg(tv,1) - tno2=pm_tv_arg(tv,2) - call out_new_line(g) - if(isdisp) then - call out_simple(g,'SUBROUTINE PM__PACKADVEC$N(NA,X,Y,D)',n=tno) - else - call out_simple(g,'SUBROUTINE PM__PACKAVEC$N(NA,X,Y)',n=tno) - endif - call out_line(g,'INTEGER(PM__LN):: NA') - call out_simple(g,'TYPE(PM__TV$N),DIMENSION(:):: X',n=tno) - call out_type(g,tno2) - call out_line(g,',DIMENSION(:)::Y') - if(isdisp) then - call out_line(g,'INTEGER(PM__LN),DIMENSION(NA):: D') - endif - call out_line(g,'CALL PM__NEW_BUFFER') - has_depth=.false. - counts=0 - call precount(g,pm_tv_arg(tv,1),counts,has_depth) - if(has_depth) then - call out_simple(g,'NP1=0') - if(isdisp) then - call out_line(g,'DO IX=1,NA') - call out_line(g,'IP1=D(IX)+1') - else - call out_line(g,'DO IP1=1,NA') - endif - call out_line(g,'NP2=SIZE('//'X'//'(IP1)%P)') - call out_line(g,'NP1=NP1+NP2') - call out_line(g,'DO IP2=1,NP2') - call outcount(g,pm_tv_arg(tv,1),'X'//'(IP1)%P(IP2)',2) - call out_line(g,'ENDDO') - call out_line(g,'ENDDO') - else - call out_line(g,'NP1=NA') - endif - call outaddcount(g,counts,1) - call out_line(g,'CALL PM__ALLOCATE_BUFFER') - call g_add_packable(g,pack_scalar,tno1) - call g_add_packable(g,pack_scalar,tno2) - call g_add_packable(g,pack_scalar,int(pm_long)) - if(isdisp) then - call out_line(g,'DO IIX=1,NA') - call out_line(g,'IX=D(IIX)+1') - else - call out_line(g,'DO IX=1,NA') - endif - call out_str(g,'NV=SIZE(X(IX)%P)') - call out_simple(g,'CALL PM__PACK$N(NV)',n=int(pm_long)) - call out_line(g,'DO IY=1,NV') - call out_simple_part(g,'CALL PM__PACK$N(X(IX)%P(IY))',n=tno1) - call out_line(g,'ENDDO') - call out_simple_part(g,'CALL PM__PACK$N(Y)',n=tno2) - call out_line(g,'ENDDO') - if(isdisp) then - call out_simple(g,'END SUBROUTINE PM__PACKADVEC$N',n=tno) - else - call out_simple(g,'END SUBROUTINE PM__PACKAVEC$N',n=tno) - endif - end subroutine gen_array_vect_pack_to_buffer - - - !=============================================================================== - ! Create subroutine PM__PACKtno(X,N) to pack the N elements of X - ! into the current buffer - ! Buffer must be allocated to correct size (determined by PM__COUNT) beforehand - !=============================================================================== - subroutine gen_pack_routine(g,tno) - type(gen_state):: g - integer,intent(in):: tno - integer,dimension(pm_int:pm_string):: counts - logical:: hasdepth - logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 - counts=0 - call out_new_line(g) - if(recur) call out_str(g,'RECURSIVE ') - call out_str(g,'SUBROUTINE PM__PACK') - call out_idx(g,tno) - call out_line(g,'(X)') - call out_type(g,tno) - call out_line(g,'::X') - call outpack(tno,'X',0) - call out_str(g,'END SUBROUTINE PM__PACK') - call out_idx(g,tno) - call out_new_line(g) - contains - - include 'fisnull.inc' - - recursive subroutine outpack(tno,varname,depth) - integer,intent(in):: tno - character(len=*),intent(in):: varname - integer,intent(in):: depth - type(pm_ptr):: tv,tlist,telem - character(len=5):: ibuffer - integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - if(tno>=pm_int.and.tno<=pm_string) then - call out_str(g,'PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_str(g,')=PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_line(g,')+1') - call out_str(g,'PM__BUFFER%') - call out_suffix(g,tno) - call out_str(g,'(PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_str(g,'))') - call out_char(g,'=') - call out_line(g,varname) - endif - case(pm_typ_is_array) - write(ibuffer,'(i5)') depth+1 - ibuffer=adjustl(ibuffer) - call out_line(g,'NP'//trim(ibuffer)//'=SIZE('//varname//'%E1%P)') - call outpack(int(pm_long),'NP'//trim(ibuffer),depth) - call out_line(g,'DO IP'//trim(ibuffer)//'=1,NP'//trim(ibuffer)) - call outpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) - call out_line(g,'ENDDO') - call outpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - write(ibuffer,'(i5)') i - call outpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) - enddo - case(pm_typ_is_poly) - call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') - call out_line(g,'PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT))=0') - call out_str(g,'SELECT TYPE(POLYVAR=>') - call out_str(g,varname) - call out_line(g,'%P)') - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - if(tno2<=pm_string) then - call out_simple(g,'TYPE IS(PM__T$S)',x=tno2) - call outpack(tno2,'POLYVAR%P',depth) - else - call out_str(g,'TYPE IS(PM__T') - call out_idx(g,tno2) - call out_line(g,')') - call out_str(g,'CALL PM__PACK') - call out_idx(g,tno2) - call out_line(g,'(POLYVAR)') - endif - call out_simple(g,'PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT))=$N',n=tno2) - enddo - endif - call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) - call outpack(pm_tv_arg(tv,1),varname,depth) - end select - end subroutine outpack - end subroutine gen_pack_routine - - !=============================================================================== - ! Create a subroutine PM__UNPACKtno(X,N) to unpack N elements from buffer into X - !=============================================================================== - subroutine gen_unpack_routine(g,tno) - type(gen_state):: g - integer,intent(in):: tno - logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 - if(recur) call out_str(g,'RECURSIVE ') - call out_str(g,'SUBROUTINE PM__UNPACK') - call out_idx(g,tno) - call out_line(g,'(X)') - call out_type(g,tno) - call out_line(g,'::X') - if(recur) call declare_poly_vars(tno) - call outunpack(tno,'X',0) - call out_str(g,'END SUBROUTINE PM__UNPACK') - call out_idx(g,tno) - call out_new_line(g) - contains - include 'fisnull.inc' - - recursive subroutine declare_poly_vars(tno) - integer,intent(in):: tno - type(pm_ptr):: tv,tlist,telem - integer:: tno2,i,n - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_poly) - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - if(tno2<=pm_string) then - call out_simple_part(g,'TYPE(PM__T$S)',x=tno2) - else - call out_type(g,tno2) - endif - call out_str(g,'::PVAL') - call out_idx(g,tno2) - call out_new_line(g) - enddo - endif - case(pm_typ_is_array,& - pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - call declare_poly_vars(pm_tv_arg(tv,i)) - enddo - end select - end subroutine declare_poly_vars - - recursive subroutine outunpack(tno,varname,depth) - integer,intent(in):: tno - character(len=*),intent(in):: varname - integer,intent(in):: depth - type(pm_ptr):: tv,tlist,telem - character(len=5):: ibuffer - integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - if(tno>=pm_int.and.tno<=pm_string) then - call out_str(g,'PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_str(g,')=PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_line(g,')+1') - call out_str(g,varname) - call out_str(g,'=PM__BUFFER%') - call out_suffix(g,tno) - call out_str(g,'(PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_line(g,'))') - endif - case(pm_typ_is_array) - write(ibuffer,'(i5)') depth+1 - ibuffer=adjustl(ibuffer) - call outunpack(int(pm_long),'NP'//trim(ibuffer),depth) - call out_line(g,'IF(ALLOCATED('//varname//'%E1%P)) DEALLOCATE('//varname//'%E1%P)') - call out_line(g,'ALLOCATE('//varname//'%E1%P(NP'//trim(ibuffer)//'))') - call out_line(g,'DO IP'//trim(ibuffer)//'=1,NP'//trim(ibuffer)) - call outunpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) - call out_line(g,'ENDDO') - call outunpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - write(ibuffer,'(i5)') i - call outunpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) - enddo - case(pm_typ_is_poly) - call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') - call out_line(g,'SELECT CASE(PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT)))') - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - call out_str(g,'CASE(') - call out_idx(g,tno2) - call out_line(g,')') - write(ibuffer,'(i5)') tno2 - if(tno2<=pm_string) then - call outunpack(tno2,'PVAL'//trim(adjustl(ibuffer))//'%P',depth) - else - call out_str(g,'CALL PM__UNPACK') - call out_idx(g,tno2) - call out_line(g,'(PVAL'//trim(adjustl(ibuffer))//')') - endif - call out_simple(g,'ALLOCATE('//varname//'%P,SOURCE=PVAL$N)',n=tno2) - enddo - endif - call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) - call outunpack(pm_tv_arg(tv,1),varname,depth) - end select - end subroutine outunpack - end subroutine gen_unpack_routine - - - !============================================================ - ! Generate a subroutine PM__COUNTtno(X,N) to count basic - ! elements in X (including dynamic sub-elements) - ! placing result in current buffer - !============================================================ - subroutine gen_count_routine(g,tno) - type(gen_state):: g - integer,intent(in):: tno - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 - if(recur) call out_str(g,'RECURSIVE ') - call out_str(g,'SUBROUTINE PM__COUNT') - call out_idx(g,tno) - call out_line(g,'(X)') - call out_type(g,tno) - call out_line(g,'::X') - counts=0 - has_depth=.false. - call precount(g,tno,counts,has_depth) - call outaddcount(g,counts,0) - if(has_depth) then - call outcount(g,tno,'X',0) - endif - call out_str(g,'END SUBROUTINE PM__COUNT') - call out_idx(g,tno) - call out_new_line(g) - end subroutine gen_count_routine - - !======================================================= - ! Determine the compile-time count of each basic type - ! in type tno. Returns has_depth if there are elements - ! with dynamic run-time sizes (arrays/polymorphic types) - !======================================================= - recursive subroutine precount(g,tno,counts,has_depth) - type(gen_state):: g - integer,intent(in):: tno - integer(pm_ln),intent(inout),dimension(pm_int:pm_string):: counts - logical,intent(inout):: has_depth - integer(pm_ln),dimension(pm_int:pm_string):: counts2 - logical:: has_depth2 - type(pm_ptr):: tv,val - integer:: i - integer(pm_ln):: n - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - if(tno>=pm_int.and.tno<=pm_string) then - counts(tno)=counts(tno)+1 - endif - case(pm_typ_is_array) - has_depth2=.false. - call precount(g,pm_tv_arg(tv,2),counts,has_depth2) - if(pm_tv_arg(tv,3)/=pm_long.and..not.has_depth2) then - call precount(g,pm_tv_arg(tv,1),counts2,has_depth) - if(.not.has_depth) then - val=pm_typ_val(g%context,pm_tv_arg(tv,3)) - counts=counts+counts2*val%data%ln(val%offset) - endif - else - has_depth=.true. - endif - counts(pm_long)=counts(pm_long)+1 - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - call precount(g,pm_tv_arg(tv,i),counts,has_depth) - enddo - case(pm_typ_is_poly) - counts(pm_int)=counts(pm_int)+1 - has_depth=.true. - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case default - call pm_panic("precount") - end select - end subroutine precount - - !=================================================================== - ! Code the addition of basic types counts determined by precount - ! to the counts entries in the current buffer - !=================================================================== - subroutine outaddcount(g,counts,depth) - type(gen_state):: g - integer(pm_ln),intent(inout),dimension(pm_int:pm_string):: counts - integer,intent(in):: depth - integer:: i - do i=pm_int,pm_string - if(counts(i)>0) then - call out_str(g,'PM__BUFFER%SIZEOF(') - call out_kind(g,i) - call out_str(g,')=PM__BUFFER%SIZEOF(') - call out_kind(g,i) - call out_str(g,')+') - call out_long(g,counts(i)) - if(depth>0) then - call out_simple_part(g,'*NP$N',n=depth) - endif - call out_new_line(g) - endif - enddo - end subroutine outaddcount - - !============================================================ - ! Output code to count dynamic elements of the type - ! -- static elements already counted by precount - !============================================================ - recursive subroutine outcount(g,tno,varname,depth) - type(gen_state):: g - integer,intent(in):: tno - character(len=*):: varname - integer,intent(in):: depth - type(pm_ptr):: tv,tlist,telem - integer:: i,n,tno2 - character(len=5):: ibuffer - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - continue - case(pm_typ_is_array) - call outcount(g,pm_tv_arg(tv,2),varname//'%E2',depth) - has_depth=.false. - counts=0 - call precount(g,pm_tv_arg(tv,1),counts,has_depth) - if(has_depth) then - write(ibuffer,'(i5)') depth+1 - ibuffer=adjustl(ibuffer) - call get_vect_size(varname) - call out_simple(g,'DO IP$N=1,NP$N',n=depth+1) - call outcount(g,pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) - call out_line(g,'ENDDO') - else - call get_vect_size(varname) - endif - call outaddcount(g,counts,depth+1) - case(pm_typ_is_poly) - call out_line(g,'SELECT TYPE(POLYVAR=>'//varname//'%P)') - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - if(tno2<=pm_string) then - call out_simple(g,'TYPE IS(PM__T$S)',x=tno2) - counts=0 - call precount(g,tno2,counts,has_depth) - call outaddcount(g,counts,depth) - else - call out_simple(g,'TYPE IS(PM__T$N)',n=tno2) - call g_add_packable(g,pack_scalar,tno2) - call out_str(g,'CALL PM__COUNT') - call out_idx(g,tno2) - call out_line(g,'(POLYVAR)') - endif - enddo - endif - call out_line(g,'END SELECT') - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - write(ibuffer,'(i5)') i - call outcount(g,pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) - enddo - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) - call outcount(g,pm_tv_arg(tv,1),varname,depth) - end select - contains - include 'fisnull.inc' - - subroutine get_vect_size(var) - character(len=*):: var - call out_simple(g,'NP$N=SIZE('//var//'%E1%P)',n=depth+1) - end subroutine get_vect_size - end subroutine outcount - - !======================================================== - ! Create subroutine PM__MAKE_MPI_TYPES that - ! creates all required MPI types from PM types, - ! fills global PM__MPI_TYPES - !======================================================== - subroutine gen_mpi_types(g) - type(gen_state):: g - integer:: i,j,n,nn,size,typ,maxargs,set_key(1) - type(pm_ptr):: keys,key,tv - - call out_new_line(g) - call out_line_noindent(g,'SUBROUTINE PM__MAKE_MPI_TYPES') - - size=pm_set_size(g%context,g%mpi_types) - if(size==0) then - call out_line_noindent(g,'END SUBROUTINE PM__MAKE_MPI_TYPES') - return - endif - - keys=pm_set_keys(g%context,g%mpi_types) - maxargs=0 - do i=0,size-1 - key=keys%data%ptr(keys%offset+i) - typ=abs(key%data%i(key%offset)) - !write(*,*) 'TYPE #',i,' ',trim(pm_typ_as_string(g%context,typ)) - call out_type(g,typ) - call out_str(g,'::T') - call out_idx(g,typ) - call out_line(g,'(2)') - tv=pm_typ_vect(g%context,typ) - maxargs=max(maxargs,pm_tv_numargs(tv)) - enddo - call out_simple(g,'INTEGER,DIMENSION($N):: DATATYPES,BLOCKLENGTHS',n=maxargs) - call out_simple(g,'INTEGER(MPI_ADDRESS_KIND),DIMENSION($N):: OFFSETS',n=maxargs) - call out_line(g,'INTEGER(MPI_ADDRESS_KIND):: LOWER,EXTENT') - call out_line(g,'BLOCKLENGTHS=1') - call out_simple(g,'ALLOCATE(PM__MPI_TYPES($N))',n=size) - - do i=0,size-1 - key=keys%data%ptr(keys%offset+i) - typ=abs(key%data%i(key%offset)) - call out_comment_line(g,pm_typ_as_string(g%context,typ)) - if(debug_g) then - write(*,*) 'MPI TYP>',pm_typ_as_string(g%context,typ) - endif - tv=pm_typ_vect(g%context,typ) - n=pm_tv_numargs(tv) - nn=0 - do j=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),& - pm_typ_has_storage)/=0) then - call out_simple(g,'CALL MPI_GET_ADDRESS(T$N(1)%E$M,OFFSETS($M),JERROR)',& - n=typ,m=j) - nn=nn+1 - endif - enddo - do j=2,nn - call out_simple(g,'OFFSETS($N)=OFFSETS($N)-OFFSETS(1)',n=j) - enddo - call out_simple(g,'CALL MPI_GET_ADDRESS(T$N(2),EXTENT,JERROR)',n=typ) - call out_line(g,'EXTENT=EXTENT-OFFSETS(1)') - call out_line(g,'OFFSETS(1)=0') - do j=1,nn - call out_comment_line(g,pm_typ_as_string(g%context,pm_tv_arg(tv,j))) - call out_get_mpi_base_type(g,pm_tv_arg(tv,j)) - call out_simple(g,'DATATYPES($N)=JBASE',n=j) - enddo - call out_simple(g,& - 'CALL MPI_TYPE_CREATE_STRUCT($N,BLOCKLENGTHS,OFFSETS,DATATYPES,JTYPE,JERROR)',& - n=nn) - call out_line(g,'CALL MPI_TYPE_CREATE_RESIZED(JTYPE,0_MPI_ADDRESS_KIND,EXTENT,JTYPE2,JERROR)') - call out_simple(g,'PM__MPI_TYPES($N)=JTYPE2',n=i+1) - enddo - - size=pm_set_size(g%context,g%mpi_root_types) - keys=pm_set_keys(g%context,g%mpi_root_types) - do i=0,size-1 - key=keys%data%ptr(keys%offset+i) - set_key(1)=abs(key%data%i(key%offset)) - j=pm_ivect_lookup(g%context,g%mpi_types,set_key,1) - if(j<0) call pm_panic('gen_mpi_types') - call out_simple(g,'CALL MPI_TYPE_COMMIT(PM__MPI_TYPES($N),JERROR)',n=j) - enddo - - call out_line_noindent(g,'END SUBROUTINE PM__MAKE_MPI_TYPES') - end subroutine gen_mpi_types - - - !******************************************************************** - ! VARIABLE AND TYPE DEFINITIONS - !******************************************************************** - - !============================================ - ! Output definition for variable at index i - ! - in communicating proc, iscomm==.true. - !============================================ - subroutine out_var_def(g,i,iscomm) - type(gen_state):: g - integer,intent(in):: i - logical,intent(in):: iscomm - integer:: ix,flags,j,oindex - logical:: isvect - - isvect=g_var_at_index_is_a_vect(g,i) - flags=g%vardata(i)%flags - ix=abs(g%vardata(i)%index) - - if(iand(g%vardata(i)%gflags,var_is_recycled)/=0) then - return - endif - - oindex=g%vardata(i)%oindex - if(debug_g) then - write(*,*) 'VAR>>',i,oindex,' ',trim(pm_typ_as_string(g%context,g%vardata(i)%tno)) - endif - -!!$ if(g_kind(g,oindex)==v_is_basic) call out_simple(g,'!'//& -!!$ trim(pm_name_as_string(g%context,g_v1(g,oindex)))) - -!!$ call out_simple_part(g,'! idx=$N / lthis=$M '//& -!!$ trim(pm_typ_as_string(g%context,g%vardata(i)%tno)),& -!!$ n=g%vardata(i)%oindex,m=g%vardata(i)%lthis) -!!$ call out_simple_part(g,'/ flags=$N state=$M',n=g%vardata(i)%flags,m=g%vardata(i)%state) -!!$ call out_simple_part(g,'/ start=$N finish=$M',n=g%vardata(i)%start,m=g%vardata(i)%finish) -!!$ call out_simple(g,'/ end_assign=$N',n=merge(1,0,g%vardata(i)%finish_on_assign)) - - if(iand(flags,v_is_chan)/=0) then - call out_str(g,'TYPE(PM__TV') - call out_type_idx(g,g%vardata(i)%tno) - call out_str(g,'_7)') - isvect=.false. - elseif(iand(flags,v_is_array_par_vect)/=0) then - call out_str(g,'TYPE(PM__TV') - call out_type_idx(g,g%vardata(i)%tno) - call out_char(g,'_') - call out_type_idx(g,g_v1(g,oindex)) - call out_char(g,')') - else - call out_type(g,g%vardata(i)%tno) - endif - - if(iand(flags,v_is_ref+v_is_param)==v_is_ref+v_is_param) then - call out_str(g,',INTENT(INOUT)') - elseif(iand(flags,v_is_param)/=0) then - call out_str(g,',INTENT(IN)') - elseif(iand(flags,v_is_result)/=0) then - if(iand(flags,v_is_chan)/=0) then - call out_str(g,',INTENT(INOUT)') - else - call out_str(g,',INTENT(OUT)') - endif - endif - - if(iand(flags,v_is_key)/=0) call out_str(g,',OPTIONAL') - - if(isvect) then - if(iand(flags,v_is_array_par_vect+v_is_array_par_dom)/=0) then - call out_str(g,',DIMENSION(:)') - elseif(iand(flags,v_is_param+v_is_result)/=0) then - if(.not.iscomm) then - call out_str(g,',DIMENSION(:)') - else - call out_str(g,',DIMENSION(N1)') - endif - else - call out_str(g,',ALLOCATABLE,DIMENSION(:)') - endif - endif - - call out_str(g,'::') - if(ix/=0) then - call out_char_idx(g,'V',ix) - else - call out_var_name_at_index(g,i) - endif - - call out_str(g,' ! '//trim(pm_typ_as_string(g%context,g%vardata(i)%tno))) - - if(pm_opts%ftn_annotate) then - call out_simple_part(g,' idx=$N', n=oindex) - endif - - call out_new_line(g) - end subroutine out_var_def - - !=========================================== - ! Output definitions for all types in - ! typeset - !============================================ - subroutine out_type_defs(g,typeset) - type(gen_state):: g - type(pm_ptr),intent(in):: typeset - integer:: i - type(pm_ptr):: keys,key - keys=pm_set_keys(g%context,typeset) - do i=0,pm_set_size(g%context,typeset)-1 - key=keys%data%ptr(keys%offset+i) - call out_type_def(g,key%data%i(key%offset),key%data%i(key%offset+1)) - call out_new_line(g) - enddo - contains - include 'fesize.inc' - end subroutine out_type_defs - - !======================================== - ! Output type definition for PM type tno - ! - dim==0 : plain type - ! - dim==pm_long : allocatable vector - ! - dim==... : fixed length vector - !======================================== - subroutine out_type_def(g,tno,dim) - type(gen_state):: g - integer,intent(in):: tno,dim - type(pm_ptr):: tv,val - integer:: i,n,k - if(tno==0) return - if(dim>0) then - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) - call out_str(g,'TYPE PM__TV') - call out_idx(g,tno) - call out_char_idx(g,'_',dim) - call out_new_line(g) - call out_type(g,tno) - if(dim==pm_long) then - call out_line(g,',DIMENSION(:),ALLOCATABLE::P') - else - val=pm_typ_val(g%context,dim) - call out_str(g,',DIMENSION(') - call out_const(g,val) - call out_str(g,')::P') - endif - call out_str(g,'END TYPE PM__TV') - call out_idx(g,tno) - call out_char_idx(g,'_',dim) - call out_new_line(g) - return - endif - call out_char(g,'!') - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) - call out_str(g,'TYPE PM__T') - call out_idx(g,tno) - call out_new_line(g) - !call out_line(g,',SEQUENTIAL') - tv=pm_typ_vect(g%context,tno) - n=pm_tv_numargs(tv) - k=pm_tv_kind(tv) - if(k==pm_typ_is_array) then - call out_str(g,'TYPE(PM__TV') - call out_type_idx(g,pm_tv_arg(tv,1)) - call out_char(g,'_') - call out_type_idx(g,pm_tv_arg(tv,3)) - call out_line(g,')::E1') - call out_type(g,pm_tv_arg(tv,2)) - call out_line(g,'::E2') - elseif(k==pm_typ_is_vect) then - continue - else - do i=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,i)),& - pm_typ_has_storage)/=0) then - call out_type(g,pm_tv_arg(tv,i)) - call out_str(g,'::E') - call out_idx(g,i) - call out_new_line(g) - endif - enddo - endif - call out_str(g,'END TYPE PM__T') - call out_idx(g,tno) - call out_new_line(g) - end subroutine out_type_def - - !================================================= - ! Output the type index for a given type - ! -- type number expect for polymorphic types - !================================================ - subroutine out_type_idx(g,tno) - type(gen_state):: g - integer,intent(in):: tno - if(pm_typ_kind(g%context,tno)==pm_typ_is_poly) then - call out_idx(g,int(pm_pointer)) - else - call out_idx(g,tno) - endif - end subroutine out_type_idx - - !============================================================ - ! Output code to allocate avar to size nc - !============================================================ - recursive subroutine out_alloc_var(g,avar,nc) - type(gen_state):: g - integer,intent(in):: avar - character(len=*),intent(in):: nc - integer:: var,i,n - var=abs(avar) - select case(g_kind(g,var)) - case(v_is_group) - n=g_v1(g,var) - do i=1,n - call out_alloc_var(g,g_ptr(g,var,i),nc) - enddo - case(v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) - write(*,*) 'v_',var - call pm_panic('out_alloc_var') - case(v_is_cove) - call out_alloc_var(g,g_v2(g,var),nc) - case(v_is_alias) - call out_alloc_var(g,g_v1(g,var),nc) - case(v_is_const,v_is_ctime_const) - continue - case default - call out_str(g,'ALLOCATE(') - call out_char_idx(g,'V',g_index(g,var)) - call out_line(g,'('//nc//'))') - end select - end subroutine out_alloc_var - - !============================================================ - ! Output code for simple operation with one output - !============================================================ - subroutine out_simple_scalar(g,str,l,n,x) - type(gen_state):: g - character(len=*),intent(in):: str - integer,intent(in):: l - integer,intent(in),optional:: n,x - integer:: arg1 - arg1=g%codes(l+comp_op_arg0+1) - if(.not.g_is_shared(g,arg1)) call gen_loop(g,l,.false.) - if(g_kind(g,arg1)/=v_is_ctime_const) then - call out_simple(g,str,l,n,x) - endif - end subroutine out_simple_scalar - - - !========================================================= - ! Return code string expanded with variable/value info - ! followed by new line - ! For expansions see out_simple_part - !========================================================= - recursive subroutine out_simple(g,str,l,n,m,x) - type(gen_state):: g - character(len=*),intent(in):: str - integer,intent(in),optional:: l,n,m,x - call out_simple_part(g,str,l,n,m,x) - call out_new_line(g) - end subroutine out_simple - - !========================================================= - ! Return code string expanded with variable/value info - ! Expansions: - ! $0 .. $9 - given argument (l must be passed) - ! $(10)... - ! $#0 .. $#9 - given argument without index - ! $#(10)... - ! $A - variable passed as x without index - ! $I - variable passed as x - ! $N - integer value passed as n - ! $M - integer value passed as m - ! $X - argument x (l must be passed) - ! $Y - argument x no index - ! $S - suffix string for pm basic type x - !========================================================= - recursive subroutine out_simple_part(g,str,l,n,m,x) - type(gen_state):: g - character(len=*),intent(in):: str - integer,intent(in),optional:: l,n,m,x - integer:: i,j,k,opt,tens - character:: c - opt=0 - k=len(str) - j=1 - do while(j<=k) - c=str(j:j) - if(c/='$') then - g%n=g%n+1 - g%linebuffer(g%n:g%n)=c - else - j=j+1 - c=str(j:j) - select case(c) - case('#') - j=j+1 - c=str(j:j) - call out_arg(g,g%codes(l+comp_op_arg0+iachar(c)-iachar('0')),arg_no_index) - case('0','1','2','3','4','5','6','7','8','9') - call out_arg(g,g%codes(l+comp_op_arg0+iachar(c)-iachar('0')),0) - case('(') - j=j+1 - c=str(j:j) - tens=iachar(c)-iachar('0') - j=j+1 - c=str(j:j) - call out_arg(g,g%codes(l+comp_op_arg0+tens*10+iachar(c)-iachar('0')),0) - j=j+1 - if(str(j:j)/=')') call pm_panic('out_simple: bad $( arg') - case('A') - call out_arg(g,x,arg_no_index) - case('I') - call out_arg(g,x,0) - - case('N') - call out_idx(g,n) - case('M') - call out_idx(g,m) - case('X') - call out_arg(g,g%codes(l+comp_op_arg0+x),0) - case('Y') - call out_arg(g,g%codes(l+comp_op_arg0+x),arg_no_index) - case('S') - call out_suffix(g,x) - case default - write(*,*) 'Bad char (',c,')' - call pm_panic('Bad char in out_simple') - end select - endif - j=j+1 - if(g%n+k-j>ftn_max_line) call out_line_break(g) - enddo - end subroutine out_simple_part - - !======================================================= - ! Output argument to a procedure call - ! - expand all arrays to two components - ! - ignore compile time constants - ! - pass channels directly - ! Options - ! arg_no_index Do not index vectors - ! arg_ix_index Index vectors with IX - ! arg_comm_arg Argument to a communicating procedure - ! arg_wrapped Argument is wrapped vector - !======================================================= - recursive subroutine out_call_arg(g,avar,opts) - type(gen_state):: g - integer,intent(in):: avar,opts - integer:: var,i,n,k,v - type(pm_ptr):: tv - var=abs(avar) - k=g_kind(g,var) - select case(k) - case(v_is_group) - select case(g_v2(g,var)) - case(v_is_array) - call out_arg(g,g_ptr(g,var,1),opts) - call out_comma(g) - call out_arg(g,g_ptr(g,var,2),opts) - case(v_is_dref,v_is_shared_dref) - n=g_v1(g,var) - if(iand(opts,arg_wrapped)/=0) then - tv=pm_typ_vect(g%context,g_type(g,var)) - call out_dref_vect_arg(g,g_ptr(g,var,1),pm_tv_arg(tv,1),opts) - call out_comma(g) - call out_call_arg(g,g_ptr(g,var,2),opts) - call out_comma(g) - do i=3,n - call out_dref_vect_arg(g,g_ptr(g,var,i),pm_tv_arg(tv,i),opts) - if(i/=n) call out_comma(g) - enddo - else - do i=1,n - call out_call_arg(g,g_ptr(g,var,i),opts) - if(i/=n) call out_comma(g) - enddo - end if - case default - n=g_v1(g,var) - do i=1,n - call out_call_arg(g,g_ptr(g,var,i),opts) - if(i/=n) call out_comma(g) - enddo - end select - case(v_is_ctime_const) - continue - case(v_is_chan_vect) - if(iand(opts,arg_comm_arg)==0) then - call out_call_arg(g,g_v1(g,var),ior(opts,arg_chan)) - else - call out_arg(g,g_v1(g,var),opts) - endif - case(v_is_vect_wrapped) - call out_call_arg(g,g_v1(g,var),ior(opts,arg_wrapped)) - case(v_is_alias) - call out_call_arg(g,g_v1(g,var),opts) - case default - if(pm_typ_kind(g%context,g_type(g,var))==pm_typ_is_array) then - call out_arg(g,var,opts) - call out_str(g,'%E1,') - call out_arg(g,var,opts) - call out_str(g,'%E2') - return - else - call out_arg(g,var,opts) - endif - end select - end subroutine out_call_arg - - !=================================================== - ! Output one element of a dref - ! - if the element is a vector it is wrapped - !=================================================== - recursive subroutine out_dref_vect_arg(g,var,tno,opts) - type(gen_state):: g - integer,intent(in):: var,tno,opts - if(pm_typ_get_mode(g%context,tno)>=sym_mirrored) then - call out_call_arg(g,var,opts) - else - call out_call_arg(g,var,ior(opts,arg_wrapped)) - endif - end subroutine out_dref_vect_arg - - !================================================ - ! Output parameter name - ! - split groups - ! - ignore compile time constants - !================================================ - recursive subroutine out_param(g,avar) - type(gen_state):: g - integer,intent(in):: avar - integer:: var,i,n,k - var=abs(avar) - k=g_kind(g,var) - select case(k) - case(v_is_group) - n=g_v1(g,var) - do i=1,n - call out_param(g,g_ptr(g,var,i)) - call out_comma(g) - enddo - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call out_param(g,g_v1(g,var)) - case(v_is_ctime_const) - continue - case(v_is_cove) - call out_param(g,g_v2(g,var)) - case default - call out_arg_name(g,var,0) - end select - end subroutine out_param - - !================================================ - ! Output argument - ! opts - - ! arg_no_index Do not index vectors - ! arg_ix_index Index vectors with IX - ! arg_wrapped Argument is wrapped vector - !================================================ - recursive subroutine out_arg(g,avar,opts) - type(gen_state):: g - integer,intent(in):: avar,opts - integer:: var,i,n,k - var=abs(avar) - k=g_kind(g,var) - select case(k) - case(v_is_group) - n=g_v1(g,var) - do i=1,n - call out_arg(g,g_ptr(g,var,i),opts) - if(i/=n) call out_comma(g) - enddo - case(v_is_sub) - call out_arg(g,g_v1(g,var),opts) - call out_str(g,'%E1%P((') - call out_arg(g,g_v2(g,var),opts) - call out_str(g,')+1)') - case(v_is_vsub) - call out_arg(g,g_v1(g,var),opts) - call out_str(g,'%P((') - call out_arg(g,g_v2(g,var),opts) - call out_str(g,')+1)') - case(v_is_vect_wrapped) - call out_arg(g,g_v1(g,var),ior(opts,arg_wrapped)) - case(v_is_elem) - call out_elem(g,g_v1(g,var),g_v2(g,var),opts) - case(v_is_unit_elem) - call out_arg(g,g_v1(g,var),opts) - case(v_is_chan_vect) - call out_arg(g,g_v1(g,var),ior(opts,arg_chan)) - case(v_is_const) - call out_const(g,g%fn%data%ptr(g%fn%offset+2+g_v1(g,var))) - case(v_is_ctime_const) - call out_const(g,g%fn%data%ptr(g%fn%offset+2+g_v1(g,var))) - case(v_is_cove) - call out_arg(g,g_v2(g,var),opts) - case(v_is_alias) - call out_arg(g,g_v1(g,var),opts) - case default - call out_arg_name(g,var,opts) - if(iand(opts,arg_chan)/=0) then - call out_str(g,'%P') - call out_loop_index(g,var,opts) - elseif(.not.g_flags_set(g,var,v_is_chan)) then - call out_loop_index(g,var,opts) - endif - end select - end subroutine out_arg - - !============================================= - ! Output variable name associated with var - !============================================= - subroutine out_arg_name(g,var,opt) - type(gen_state):: g - integer,intent(in):: var,opt - integer:: i - if(g_var_is_merged(g,var)) then - call out_char_idx(g,'V',g_index(g,var)) - else - if(g%varindex(var)==0) then - write(*,*) 'var=',var,'kind=',g_kind(g,var) - call pm_panic('out_arg_name') - endif - i=g%varindex(var) - call out_var_name_at_index(g,i) - endif - end subroutine out_arg_name - - !============================================================== - ! If variable v is a vector than append the required index - ! - usually the index variable for the associated parallel - ! context - ! - can also be IX for opt==arg_ix_index - ! - can also be IDO for use inside op_do_at - ! - can also be 1 outside of active loop for given context - !============================================================= - subroutine out_loop_index(g,v,opt) - type(gen_state):: g - integer,intent(in):: v,opt - integer:: i,lthis - - if(g_is_a_vect(g,v)) then - lthis=g_lthis(g,v) - if(iand(opt,arg_ix_index)/=0.and.g_is_vect(g,v)) then - call out_str(g,'(IX)') - elseif(iand(opt,arg_no_index+arg_wrapped)==0.or.lthis/=g%lthis.and.iand(opt,arg_wrapped)==0) then - if(lthis==g%lalt) then - call out_str(g,'(IDO)') - elseif(.not.g%lstack(lthis)%loop_active.or.lthis==0) then - call out_str(g,'(1)') - else - call out_char(g,'(') - call out_char_idx(g,'I',lthis) - call out_char(g,')') - endif - endif - if(g_flags_set(g,v,v_is_array_par_vect)) then - call out_str(g,'%P') - endif - endif - end subroutine out_loop_index - - !==================================================== - ! Output var.n as var%n - !==================================================== - recursive subroutine out_elem(g,var,n,opts) - type(gen_state):: g - integer,intent(in):: var,n,opts - call out_arg(g,var,opts) - call out_char(g,'%') - call out_char_idx(g,'E',n) - end subroutine out_elem - - !==================================================== - ! Output variable at given index - !==================================================== - subroutine out_var_at_index(g,i) - type(gen_state):: g - integer,intent(in):: i - integer:: j - j=abs(g%vardata(i)%index) - if(j/=0) then - call out_char_idx(g,'V',j) - else - call out_var_name_at_index(g,i) - endif - end subroutine out_var_at_index - - !==================================================== - ! Output constant value associated with variable v - !==================================================== - subroutine out_const(g,v) - type(gen_state):: g - type(pm_ptr),intent(in):: v - character(len=max_line):: buffer - integer:: vk,i,n - buffer=' ' - vk=pm_fast_vkind(v) - select case(vk) - case(pm_int) - write(buffer,*) v%data%i(v%offset) - case(pm_long) - write(buffer,*) v%data%ln(v%offset) - call append('_PM__LN') - case(pm_longlong) - write(buffer,*) v%data%lln(v%offset) - call append('_PM__LN') - case(pm_int8) - write(buffer,*) v%data%i8(v%offset) - call append('_PM__I8') - case(pm_int16) - write(buffer,*) v%data%i16(v%offset) - call append('_PM__I16') - case(pm_int32) - write(buffer,*) v%data%i32(v%offset) - call append('_PM__I32') - case(pm_int64) - write(buffer,*) v%data%i64(v%offset) - call append('_PM__I64') - case(pm_single) - write(buffer,*) v%data%r(v%offset) - case(pm_double) - write(buffer,*) v%data%d(v%offset) - call append('_PM__D') - case(pm_single_complex) - write(buffer,*) v%data%c(v%offset) - case(pm_double_complex) - write(buffer,*) '(',real(v%data%dc(v%offset)) - call append('_PM__D,') - write(buffer(len_trim(buffer)+1:),*) imag(v%data%dc(v%offset)) - call append('_PM__D)') - case(pm_logical) - if(v%data%l(v%offset)) then - buffer='.TRUE.' - else - buffer='.FALSE.' - endif - case(pm_string) - if(g%n+20>ftn_max_line) call out_line_break(g) - n=pm_fast_esize(v) - g%linebuffer(g%n+1:g%n+12)='PM__STRVAL("' - g%n=g%n+12 - do i=0,n-1 - if(g%n>ftn_max_line-5) call out_line_break(g) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=v%data%s(v%offset+i) - enddo - g%linebuffer(g%n+1:g%n+2)='")' - g%n=g%n+2 - return - case(0:pm_null) - return - end select - buffer=adjustl(buffer) - n=len_trim(buffer) - if(g%n+n>ftn_max_line) then - call out_line_break(g) - endif - g%linebuffer(g%n+1:g%n+1)='(' - g%linebuffer(g%n+2:g%n+n+1)=buffer(1:n) - g%linebuffer(g%n+n+2:g%n+n+2)=')' - g%n=g%n+n+2 - contains - include 'fvkind.inc' - include 'fesize.inc' - - subroutine append(c) - character(len=*),intent(in):: c - integer:: m - m=len_trim(buffer) - buffer(m+1:m+len(c))=c - end subroutine append - - end subroutine out_const - - !=========================================== - ! Output PM type typ as a Fortran type - !=========================================== - subroutine out_type(g,typ) - type(gen_state):: g - integer,intent(in):: typ - type(pm_ptr):: tv - integer:: tno - tno=pm_typ_strip_to_basic(g%context,typ) - select case(tno) - case(pm_int) - call out_str(g,'INTEGER') - case(pm_long) - call out_str(g,'INTEGER(PM__LN)') - case(pm_longlong) - call out_str(g,'INTEGER(PM__LLN)') - case(pm_int8) - call out_str(g,'INTEGER(PM__I8)') - case(pm_int16) - call out_str(g,'INTEGER(PM__I16)') - case(pm_int32) - call out_str(g,'INTEGER(PM__I32)') - case(pm_int64) - call out_str(g,'INTEGER(PM__I64)') - case(pm_single) - call out_str(g,'REAL') - case(pm_double) - call out_str(g,'REAL(PM__D)') - case(pm_single_complex) - call out_str(g,'COMPLEX') - case(pm_double_complex) - call out_str(g,'COMPLEX(PM__D)') - case(pm_logical) - call out_str(g,'LOGICAL') - case(pm_string) - call out_str(g,'CHARACTER(LEN=1)') - case(pm_string_type) - call out_str(g,'TYPE(PM__STR)') - case(pm_pointer,pm_poly_type) - call out_str(g,'TYPE(PM__POLY)') - case default - tv=pm_typ_vect(g%context,tno) - if(pm_tv_kind(tv)==pm_typ_is_poly) then - call out_str(g,'TYPE(PM__POLY)') - else - call out_str(g,'TYPE(PM__T') - call out_idx(g,tno) - call out_char(g,')') - endif - end select - end subroutine out_type - - !=========================================== - ! Output a kind (integer enum) associated with - ! basic type tno - !=========================================== - subroutine out_kind(g,tno) - type(gen_state):: g - integer,intent(in):: tno - select case(tno) - case(pm_int) - call out_str(g,'PM__INT') - case(pm_long) - call out_str(g,'PM__LONG') - case(pm_longlong) - call out_str(g,'PM__LONGLONG') - case(pm_int8) - call out_str(g,'PM__INT8') - case(pm_int16) - call out_str(g,'PM__INT16') - case(pm_int32) - call out_str(g,'PM__INT32') - case(pm_int64) - call out_str(g,'PM__INT64') - case(pm_single) - call out_str(g,'PM__SINGLE') - case(pm_double) - call out_str(g,'PM__DOUBLE') - case(pm_single_complex) - call out_str(g,'PM__SINGLE_COMPLEX') - case(pm_double_complex) - call out_str(g,'PM__DOUBLE_COMPLEX') - case(pm_logical) - call out_str(g,'PM__LOGICAL') - end select - end subroutine out_kind - - !=========================================== - ! Output a standard suffix associated with - ! basic type tno - !=========================================== - subroutine out_suffix(g,tno) - type(gen_state):: g - integer,intent(in):: tno - select case(tno) - case(pm_int) - call out_str(g,'I') - case(pm_long) - call out_str(g,'LN') - case(pm_longlong) - call out_str(g,'LLN') - case(pm_int8) - call out_str(g,'I8') - case(pm_int16) - call out_str(g,'I16') - case(pm_int32) - call out_str(g,'I32') - case(pm_int64) - call out_str(g,'I64') - case(pm_single) - call out_str(g,'R') - case(pm_double) - call out_str(g,'D') - case(pm_single_complex) - call out_str(g,'C') - case(pm_double_complex) - call out_str(g,'DC') - case(pm_logical) - call out_str(g,'L') - end select - end subroutine out_suffix - - !=========================================== - ! Output code to place the MPI type that - ! corresponds to tno in JBASE - !========================================== - subroutine out_get_mpi_base_type(g,tno) - type(gen_state):: g - integer,intent(in):: tno - integer:: j - call out_str(g,'JBASE=') - select case(tno) - case(pm_int) - call out_line(g,'MPI_INTEGER') - case(pm_long) - call out_line(g,'MPI_AINT') - case(pm_longlong) - call out_line(g,'MPI_OFFSET') - case(pm_int8) - call out_line(g,'MPI_INTEGER1') - case(pm_int16) - call out_line(g,'MPI_INTEGER2') - case(pm_int32) - call out_line(g,'MPI_INTEGER4') - case(pm_int64) - call out_line(g,'MPI_INTEGER8') - case(pm_single) - call out_line(g,'MPI_REAL') - case(pm_double) - call out_line(g,'MPI_DOUBLE_PRECISION') - case(pm_single_complex) - call out_line(g,'MPI_COMPLEX') - case(pm_double_complex) - call out_line(g,'MPI_DOUBLE_COMPLEX') - case default - j=add_mpi_type(g,tno) - call out_simple(g,'PM__MPI_TYPES($N)',n=j) - end select - end subroutine out_get_mpi_base_type - - !============================================= - ! Add to the set of mpi composite types - ! that will need to be generated - !============================================== - recursive function add_mpi_type(g,typ) result(j) - type(gen_state):: g - integer,intent(in):: typ - integer:: j - type(pm_ptr):: tv - integer:: i,tno - if(debug_g) then - write(*,*) 'ADD MPI TYPE',trim(pm_typ_as_string(g%context,typ)) - endif - tno=pm_typ_strip_to_basic(g%context,typ) - if(tno<=pm_string) return - j=check_set(tno) - if(j>0) return - j=add_to_root_set(tno) - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_struct,pm_typ_is_rec) - do i=1,pm_tv_numargs(tv) - j=add_mpi_type(g,pm_tv_arg(tv,i)) - enddo - j=add_to_set(tno) - case(pm_typ_is_poly) - call pm_panic('add_mpi_type: poly type') - case(pm_typ_is_array) - if(pm_tv_arg(tv,3)==pm_long) then - call pm_panic('add_mpi_type: var length array') - else - j=add_mpi_type(g,pm_tv_arg(tv,1)) - j=add_mpi_type(g,pm_tv_arg(tv,2)) - j=add_to_set(tno) - endif - case default - write(*,*) 'Type',pm_typ_as_string(g%context,tno),' kind ',pm_tv_kind(tv) - call pm_panic('add_mpi_type') - j=0 - end select - contains - - function check_set(tno) result(j) - integer,intent(in):: tno - integer:: j - integer:: key(1) - key(1)=tno - j=pm_ivect_lookup(g%context,g%mpi_types,key,1) - end function check_set - - function add_to_set(tno) result(j) - integer,intent(in):: tno - integer:: j,key(1) - key(1)=tno - j=pm_iset_add(g%context,g%mpi_types,key,1) - end function add_to_set - - function check_root_set(tno) result(j) - integer,intent(in):: tno - integer:: j - integer:: key(1) - key(1)=tno - j=pm_ivect_lookup(g%context,g%mpi_root_types,key,1) - end function check_root_set - - function add_to_root_set(tno) result(j) - integer,intent(in):: tno - integer:: j,key(1) - key(1)=tno - j=pm_iset_add(g%context,g%mpi_root_types,key,1) - end function add_to_root_set - - end function add_mpi_type - - !========================================= - ! Output given character followed by an - ! integer index - !========================================= - subroutine out_char_idx(g,ltr,idx) - type(gen_state):: g - integer,intent(in):: idx - character,intent(in):: ltr - integer:: i,j - if(idx<0) call pm_panic('out_char_idx') - if(g%n>ftn_max_line-ftn_max_name) & - call out_line_break(g) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=ltr - i=idx - j=10 - do while(j<=i) - j=j*10 - end do - j=j/10 - do while(j>0) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=& - achar(iachar('0')+i/j) - i=mod(i,j) - j=j/10 - enddo - end subroutine out_char_idx - - !========================================= - ! Output integer index - !========================================= - subroutine out_idx(g,idx) - type(gen_state):: g - integer,intent(in):: idx - integer:: i,j - if(g%n>ftn_max_line-ftn_max_name) & - call out_line_break(g) - i=idx - j=10 - do while(j<=i) - j=j*10 - end do - j=j/10 - do while(j>0) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=& - achar(iachar('0')+i/j) - i=mod(i,j) - j=j/10 - enddo - end subroutine out_idx - - !========================================= - ! Output long integer number - !========================================= - subroutine out_long(g,idx) - type(gen_state):: g - integer(pm_ln),intent(in):: idx - integer(pm_ln):: i,j - if(g%n>ftn_max_line-ftn_max_name) & - call out_line_break(g) - i=idx - j=10 - do while(j<=i) - j=j*10 - end do - j=j/10 - do while(j>0) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=& - achar(iachar('0')+i/j) - i=mod(i,j) - j=j/10 - enddo - g%linebuffer(g%n+1:g%n+7)='_PM__LN' - g%n=g%n+7 - end subroutine out_long - - !========================================= - ! Output given string as a complete line - !========================================= - subroutine out_line(g,str) - type(gen_state):: g - character(len=*):: str - call out_str(g,str) - call out_new_line(g) - end subroutine out_line - - !========================================= - ! Output comment line with text str - !========================================= - subroutine out_comment_line(g,str) - type(gen_state):: g - character(len=*):: str - call out_new_line(g) - call out_char(g,'!') - call out_char(g,' ') - if(len(str)>ftn_max_line-5) then - call out_str(g,str(1:ftn_max_line-5)) - else - call out_str(g,str) - endif - call out_new_line(g) - end subroutine out_comment_line - - !================================== - ! Output a given string - !================================== - subroutine out_str(g,str) - type(gen_state):: g - character(len=*):: str - integer:: m - m=len(str) - if(g%n+m>ftn_max_line) call out_line_break(g) - if(g%n+m>ftn_max_line) call pm_panic('line too long') - g%linebuffer(g%n+1:g%n+m)=str - g%n=g%n+m - end subroutine out_str - - - !========================= - ! Output given character - !========================= - subroutine out_char(g,str) - type(gen_state):: g - character(len=1):: str - if(g%n+1>ftn_max_line) call out_line_break(g) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=str - end subroutine out_char - - !=============================================== - ! Output comma providing last character was - ! not a comma or open parenthesis - !================================================ - subroutine out_comma(g) - type(gen_state):: g - if(g%linebuffer(g%n:g%n)/=','& - .and.g%linebuffer(g%n:g%n)/='(') call out_char(g,',') - end subroutine out_comma - - !=============================================== - ! Output close brackets - removing any trailing - ! comma - !================================================ - subroutine out_close(g) - type(gen_state):: g - if(g%linebuffer(g%n:g%n)/=',') then - g%n=g%n+1 - if(g%n>ftn_max_line) call out_line_break(g) - endif - g%linebuffer(g%n:g%n)=')' - end subroutine out_close - - !============================== - ! Start a new line - !============================== - subroutine out_new_line(g) - type(gen_state):: g - g%line_breaks=0 - write(g%outunit,'(A)') g%linebuffer(1:g%n) - g%linebuffer(1:2)=' ' - g%n=2 - end subroutine out_new_line - - !================================== - ! Start a new continuation line - !================================== - subroutine out_line_break(g) - type(gen_state):: g - g%line_breaks=g%line_breaks+1 - if(g%line_breaks>=pm_opts%ftn_lines) then - call pm_panic('Program too complex - generated Fortran subexpression too long') - endif - write(g%outunit,'(A,"&")') g%linebuffer(1:g%n) - g%n=1 - g%linebuffer(1:1)='&' - end subroutine out_line_break - - !==================================================== - ! Output the start of a line with no starting indent - !==================================================== - subroutine out_str_noindent(g,str) - type(gen_state):: g - character(len=*):: str - g%linebuffer=str - g%n=len_trim(g%linebuffer) - end subroutine out_str_noindent - - !====================================== - ! Output a line with no starting indent - !====================================== - subroutine out_line_noindent(g,str) - type(gen_state):: g - character(len=*):: str - g%line_breaks=0 - write(g%outunit,'(A)') str - g%linebuffer(1:1)=' ' - g%n=1 - end subroutine out_line_noindent - - - !========================================================= - ! Output variable name for the given index - !========================================================= - subroutine out_var_name_at_index(g,i) - type(gen_state):: g - integer,intent(in):: i - character(len=ftn_max_name-8):: name - call out_check_name_has_space(g) - call out_char_idx(g,'X',i) - if(pm_opts%ftn_name_vars.or.& - pm_opts%ftn_name_params.and.& - iand(g%vardata(i)%flags,v_is_param)/=0) then - call out_ftn_name(g,g%vardata(i)%name) - endif - end subroutine out_var_name_at_index - - !========================================================= - ! Output Fortran name contribution for a PM name - !========================================================= - subroutine out_ftn_name(g,name) - type(gen_state):: g - integer,intent(in):: name - integer:: n - character(len=ftn_max_name-8):: name_str - n=pm_name_stem(g%context,name) - if(n>num_sym) then - name_str=pm_name_as_string(g%context,n) - call out_char(g,'_') - call out_str(g,trim(name_str)) - endif - end subroutine out_ftn_name - - !========================================================= - ! Check if there is space on the current line for a name - ! - if not, start new continuation line - !========================================================= - subroutine out_check_name_has_space(g) - type(gen_state):: g - if(g%n+ftn_max_name>ftn_max_line) call out_line_break(g) - end subroutine out_check_name_has_space - - !********************************************************** - ! SERVICE ROUTINES (VARIABLES) - !********************************************************** - - !======================================================== - ! Get kind of variable v - !======================================================== - function g_kind(g,n) result(kind) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: kind - integer:: info - info=g%vars(abs(n)) - kind=iand(info,cvar_flag_mask) - end function g_kind - - !======================================================== - ! Get first value associated with variable v - !======================================================== - function g_v1(g,n) result(v1) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: v1 - integer:: info - info=g%vars(abs(n)) - v1=info/cvar_flag_mult - end function g_v1 - - !======================================================== - ! Get second value associated with variable v - !======================================================== - function g_v2(g,n) result(v2) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: v2 - integer:: info - info=g%vars(abs(n)+1) - v2=info/cvar_flag_mult - end function g_v2 - - - !======================================================== - ! Set second value associated with variable v - !======================================================== - subroutine g_set_v2(g,n,v) - type(gen_state),intent(inout):: g - integer,intent(in):: n,v - g%vars(abs(n)+1)=v*cvar_flag_mult - end subroutine g_set_v2 - - !======================================================== - ! Get type associated with variable v - !======================================================== - function g_type(g,n) result(typ) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: typ - integer:: info - info=g%vars(abs(n)+2) - typ=info/cvar_flag_mult - end function g_type - - !======================================================== - ! Get pointer #i associated with variable v - !======================================================== - function g_ptr(g,n,i) result(v) - type(gen_state),intent(inout):: g - integer,intent(in):: n,i - integer:: v - if(pm_debug_checks) then - if(g_kind(g,n)/=v_is_group) call pm_panic('g_ptr - kind') - if(g_v1(g,n)pm_init_gc() - call pm_init_compilation - call pm_init_names(context) - call init_typ(context) - - ! ****** Command line ***** - - reg=>pm_register(context,'main',ve) - - if(pm_get_cl_count()==1) then - call pm_get_cl_arg(1,str) - out_debug_files=.false. - else if(pm_get_cl_count()==2) then - call pm_get_cl_arg(1,str) - if(str/='-d') call usage() - out_debug_files=pm_main_process - call pm_get_cl_arg(2,str) - else - call usage() - endif - - call pm_module_filename(str) - !write(*,*) 'Input file:',trim(str) - if(.not.pm_file_exists(str)) call usage() - - ! ************* Parser ******************** - if(pm_debug_level>1) write(*,*) 'PARSING>>' - - ! Parse sytem module - call init_parser(parser,context) - call sysdefs(parser) - call pm_gc(context,.false.) - if(out_debug_files) then - open(unit=9,file='sysmod.dmp') - call dump_module(context,9,parser%sysmodl) - close(9) - endif - - ! Parse other modules - name=pm_name_entry(context,trim(str)) - call new_modl(parser,name) - root=parser%modls - do - parser%modl=parser%modls - if(pm_fast_isnull(parser%modl)) exit - parser%modls=parser%modl%data%ptr(& - parser%modl%offset+modl_link) - if(pm_fast_isnull(parser%modl)) exit - str=' ' - call pm_name_string(context,& - int(get_modl_name(parser%modl),pm_p),str) - call pm_module_filename(str) - call pm_open_file(pm_comp_file_unit,str,ok) - if(.not.ok) then - if(pm_main_process) then - write(*,*) 'Cannot open: '//trim(str) - call pm_stop('Compilation terminated') - endif - endif - parser%iunit=pm_comp_file_unit - parser%lineno=0 - call next_line(parser) - call scan(parser) - call decl(parser) - close(pm_comp_file_unit) - call pm_gc(context,.false.) - if(out_debug_files) then - open(unit=9,file=trim(str)//'.dmp') - call dump_module(context,9,parser%modl) - close(9) - endif - enddo - if(parser%error_count>0) call pm_stop('Parse errors') - call pm_gc(context,.false.) - - ! ***************Linker******************* - if(pm_debug_level>1) write(*,*) 'LINKING>>' - call link_includes(context,parser%modl_dict) - call pm_gc(context,.false.) - if(out_debug_files) then - open(unit=pm_comp_file_unit,file='linker.out') - call dump_module(context,pm_comp_file_unit,root) - close(pm_comp_file_unit) - endif - - !************ Code generation *************** - if(pm_debug_level>1) write(*,*) 'CODE GENERATION>>' - prog=root%data%ptr(root%offset+modl_stmts) - if(pm_fast_isnull(prog)) call pm_stop('No program defined to run') - call init_coder(context,coder) - call trav_prog(coder,prog) - if(out_debug_files) then - open(unit=pm_comp_file_unit,file='codegen.out') - call qdump_code_tree(coder,pm_null_obj,pm_comp_file_unit,coder%vstack(1),1) - call dump_sigs(coder,pm_comp_file_unit) - close(pm_comp_file_unit) - - endif - if(coder%num_errors>0) call pm_stop('Code generation errors') - - ! *********** Type Inference ********************* - if(pm_debug_level>1) write(*,*) 'TYPE INFERENCE>>' - call prc_prog(coder) - if(out_debug_files) then - open(unit=pm_comp_file_unit,file='infer.out') - call dump_code_tree(coder,pm_null_obj,pm_comp_file_unit,coder%vstack(1),1) - call dump_res_sigs(coder,pm_comp_file_unit) - close(pm_comp_file_unit) - endif - if(coder%num_errors>0) call pm_stop('Type inference errors') - - !**************** Backend ********************** - if(pm_debug_level>1) write(*,*) 'FINAL STAGE>>' - call init_fs(context,fs,coder%proc_cache) - open(unit=pm_comp_file_unit,file='pmout.f90') - fs%outunit=pm_comp_file_unit - call finalise_prog(fs,coder%vstack(1)) - close(unit=pm_comp_file_unit) - if(coder%num_errors>0) call pm_stop('Errors in final coding stage') -contains - - include 'fisnull.inc' - include 'fnewnc.inc' - - subroutine usage() - if(pm_main_process) then - write(*,*) 'Usage: pm [-d] root_module_name' - write(*,*) 'Module name should not have .pmm suffix' - write(*,*) 'Option -d outputs intermediate compilation for debug' - endif - call pm_stop(' ') - end subroutine usage - -end program pm diff --git a/src/cnodes.f90 b/src/cnodes.f90 new file mode 100644 index 0000000..0e3bf71 --- /dev/null +++ b/src/cnodes.f90 @@ -0,0 +1,811 @@ +! +! PM (Parallel Models) Programming Language +! +! Released under the MIT License (MIT) +! +! Copyright (c) Tim Bellerby, 2024 +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. + +module pm_cnodes + + use pm_kinds + use pm_sysdep + use pm_compbase + use pm_memory + use pm_hash + use pm_options + use pm_lib + use pm_symbol + use pm_types + use pm_ast + use pm_sysdefs + + ! Debug cnode operations + logical,parameter:: debug_cnodes=.false. + + ! Magic number for code tree nodes + integer,parameter:: cnode_magic_no=10456_pm_p + + ! Offsets common to all cnode structures + integer,parameter:: cnode_magic=0 + integer,parameter:: cnode_kind=1 + integer,parameter:: cnode_modl_name=2 + integer,parameter:: cnode_lineno=3 + integer,parameter:: cnode_charno=4 + integer,parameter:: cnode_args=5 + + ! Types of cnode structure + integer,parameter:: cnode_is_cblock=1 + integer,parameter:: cnode_is_var=2 + integer,parameter:: cnode_is_const=3 + integer,parameter:: cnode_is_call=4 + integer,parameter:: cnode_is_arglist=5 + integer,parameter:: cnode_is_builtin=6 + integer,parameter:: cnode_is_proc=7 + integer,parameter:: cnode_is_resolved_proc=8 + integer,parameter:: cnode_is_arg_constraint=9 + integer,parameter:: cnode_is_par_constraint=10 + integer,parameter:: cnode_is_type_constraint=11 + !integer,parameter:: cnode_is_interface_constraint=12 + integer,parameter:: cnode_is_any_sig=13 + integer,parameter:: cnode_is_autoconv_sig=14 + integer,parameter:: cnode_num_kinds=14 + + ! Offsets into cblock cnodes + integer,parameter:: cblock_parent=cnode_args+0 + integer,parameter:: cblock_first_var=cnode_args+1 + integer,parameter:: cblock_last_var=cnode_args+2 + integer,parameter:: cblock_first_call=cnode_args+3 + integer,parameter:: cblock_last_call=cnode_args+4 + integer,parameter:: cblock_sym=cnode_args+5 + integer,parameter:: cblock_start=cnode_args+6 + integer,parameter:: cblock_flags=cnode_args+7 + integer,parameter:: cblock_index=cnode_args+8 + integer,parameter:: cblock_last_loop_call=cnode_args+9 + integer,parameter:: cblock_var_inits=cnode_args+10 + integer,parameter:: cblock_node_size=11 + + ! Flags for cblocks + integer,parameter:: cblock_is_comm=1 + integer,parameter:: cblock_is_open=2 + + ! Offsets into call cnodes + integer,parameter:: call_args=cnode_args+0 + integer,parameter:: call_parent=cnode_args+1 + integer,parameter:: call_sig=cnode_args+2 + integer,parameter:: call_flags=cnode_args+3 + integer,parameter:: call_link=cnode_args+4 + integer,parameter:: call_nret=cnode_args+5 + integer,parameter:: call_nkeys=cnode_args+6 + integer,parameter:: call_index=cnode_args+7 + integer,parameter:: call_par_depth=cnode_args+8 + integer,parameter:: call_var=cnode_args+9 + integer,parameter:: call_amp=cnode_args+10 + integer,parameter:: call_node_size=11 + + ! Flags for call nodes + ! (call_is_comm=1.. defined in parser) + integer,parameter:: call_is_fixed = 2**10 + integer,parameter:: call_is_assign_call = 2**11 + integer,parameter:: call_is_vararg = 2**12 + integer,parameter:: call_inline_when_compiling = 2**13 + integer,parameter:: call_dup_result = 2**14 + integer,parameter:: call_is_cond = 2**15 + integer,parameter:: call_is_no_touch = 2**16 + integer,parameter:: call_is_unlabelled = 2**17 + + ! Offsets into var cnodes + integer,parameter:: var_parent=cnode_args+0 + integer,parameter:: var_name=cnode_args+1 + integer,parameter:: var_flags=cnode_args+2 + integer,parameter:: var_link=cnode_args+3 + integer,parameter:: var_index=cnode_args+4 + integer,parameter:: var_par_depth=cnode_args+5 + integer,parameter:: var_create_depth = cnode_args + 6 + integer,parameter:: var_if_scope = cnode_args + 7 + integer,parameter:: var_node_size=8 + integer,parameter:: var_extra_info=cnode_args+8 + + ! Flags for var cnodes + integer,parameter:: var_is_var=1 + integer,parameter:: var_is_ref=2 + integer,parameter:: var_is_param=4 + integer,parameter:: var_is_shadowed=16 + integer,parameter:: var_is_imported=32 + integer,parameter:: var_is_accessed=64 + integer,parameter:: var_is_changed=128 + integer,parameter:: var_is_multi_access=256 + integer,parameter:: var_is_key=512 + integer,parameter:: var_is_varg=1024 + integer,parameter:: var_is_par_var=2048 + integer,parameter:: var_is_incomplete=4096 + integer,parameter:: var_is_aliased=8192 + integer,parameter:: var_is_not_inited=16384 + integer,parameter:: var_is_no_import_export=32768 + integer,parameter:: var_is_sync=65536 + + ! Offsets into proc nodes + integer,parameter:: pr_cblock=cnode_args+0 + integer,parameter:: pr_max_index=cnode_args+1 + integer,parameter:: pr_recurse=cnode_args+2 + integer,parameter:: pr_id=cnode_args+3 + integer,parameter:: pr_rtype=cnode_args+4 ! Must be same as bi_rtype + integer,parameter:: pr_nargs=cnode_args+5 + integer,parameter:: pr_nkeys=cnode_args+6 + integer,parameter:: pr_nret=cnode_args+7 + integer,parameter:: pr_flags=cnode_args+8 + integer,parameter:: pr_name=cnode_args+9 + integer,parameter:: pr_ncalls=cnode_args+10 + integer,parameter:: pr_tkeys=cnode_args+11 + integer,parameter:: pr_node_size=12 + + ! Offsets into builtin nodes + integer,parameter:: bi_opcode=cnode_args+0 + integer,parameter:: bi_opcode2=cnode_args+1 + integer,parameter:: bi_data=cnode_args+2 + integer,parameter:: bi_flags=cnode_args+3 + integer,parameter:: bi_rtype=cnode_args+4 ! Must be same as pr_rtype + integer,parameter:: bi_rcode=cnode_args+5 + integer,parameter:: bi_rsym=cnode_args+6 + integer,parameter:: bi_id=cnode_args+7 + integer,parameter:: bi_node_size=8 + +contains + + !================================= + ! Check cnode (debugging) + !================================= + subroutine check_cnode(ptr,n) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer(pm_p):: m + if(.not.pm_fast_vkind(ptr)==pm_pointer) then + write(*,*) 'vKind=',ptr%data%vkind + call pm_panic('cnode not ptr') + endif + if(ptr%data%ptr(ptr%offset)%offset/=cnode_magic_no) then + call pm_panic('bad cnode magic no') + endif + m=ptr%data%ptr(ptr%offset+1)%offset + if(m<1.or.m>cnode_num_kinds) & + call pm_panic('cnode bad kind') + if(n<0.or.n>pm_fast_esize(ptr)) & + call pm_panic('bad cnode offset') + contains + include 'fvkind.inc' + include 'fesize.inc' + end subroutine check_cnode + + !========================================== + ! Get argument n from cnode + !========================================== + function cnode_arg(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + type(pm_ptr):: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+cnode_args+n-1) + end function cnode_arg + + !====================================== + ! Get element n from cnode + !====================================== + function cnode_get(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + type(pm_ptr):: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n) + end function cnode_get + + !==================================== + ! Set element n of cnode + !==================================== + subroutine cnode_set(context,ptr,n,val) + type(pm_context),pointer:: context + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + type(pm_ptr),intent(in):: val + if(debug_cnodes) call check_cnode(ptr,n) + call pm_ptr_assign(context,ptr,int(n,pm_ln),val) + end subroutine cnode_set + + ! ======================================== + ! Get element n from cnode as a number + !========================================= + function cnode_get_num(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + end function cnode_get_num + + !============================================ + ! Get argument n from cnode as a number + !============================================ + function cnode_num_arg(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n+cnode_args-1)%offset + end function cnode_num_arg + + !========================================= + ! Get element n from cnode as a name + !========================================= + function cnode_get_name(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + end function cnode_get_name + + !========================================== + ! Set element n in cnode to a new number + ! (must be number already) + !========================================== + subroutine cnode_set_num(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + if(debug_cnodes) call check_cnode(ptr,n) + ptr%data%ptr(ptr%offset+n)%offset=val + end subroutine cnode_set_num + + !========================================== + ! Increment argument n from cnode + !========================================== + subroutine cnode_incr_num(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + if(debug_cnodes) call check_cnode(ptr,n) + ptr%data%ptr(ptr%offset+n)%offset=& + ptr%data%ptr(ptr%offset+n)%offset+val + end subroutine cnode_incr_num + + !============================================== + ! Set given flags in an element of a cnode + ! (bitwise or of existing number) + !============================================== + subroutine cnode_set_flags(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + type(pm_ptr):: p + if(debug_cnodes) then + call check_cnode(ptr,n) + p=ptr%data%ptr(ptr%offset+n) + if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then + write(*,*) 'vkind=',pm_fast_vkind(ptr) + call pm_panic('Set flags') + endif + if(cnode_get_kind(ptr)==cnode_is_var.and.& + n/=var_flags.or.& + cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& + cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then + call pm_panic('set flags') + endif + endif + ptr%data%ptr(ptr%offset+n)%offset=ior(& + ptr%data%ptr(ptr%offset+n)%offset,int(val,pm_p)) + contains + include 'fvkind.inc' + end subroutine cnode_set_flags + + !============================================ + ! Clear flags in element of a code code + ! (Bitwise clear of exiting number) + !============================================ + subroutine cnode_clear_flags(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + type(pm_ptr):: p + if(debug_cnodes) then + call check_cnode(ptr,n) + p=ptr%data%ptr(ptr%offset+n) + if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then + write(*,*) 'vkind=',pm_fast_vkind(ptr) + call pm_panic('Set flags') + endif + if(cnode_get_kind(ptr)==cnode_is_var.and.& + n/=var_flags.or.& + cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& + cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then + call pm_panic('set flags') + endif + endif + ptr%data%ptr(ptr%offset+n)%offset=iand(& + ptr%data%ptr(ptr%offset+n)%offset,not(int(val,pm_p))) + contains + include 'fvkind.inc' + end subroutine cnode_clear_flags + + !=================================================================== + ! Check all given flags in a given element of a cnode are clear + ! (bitwise and of extisting number and check for zero) + !=================================================================== + function cnode_flags_clear(ptr,n,flags) result(ok) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n,flags + logical:: ok + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + ok=iand(flags,val)==0 + end function cnode_flags_clear + + !============================================================ + ! Check all given flags in an element of a cnode are set + ! (bitwise and) + !============================================================ + function cnode_flags_set(ptr,n,flags) result(ok) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n,flags + logical:: ok + integer(pm_p):: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + ok=iand(flags,int(val))==flags + end function cnode_flags_set + + !========================================== + ! Return kind of a cnode + !========================================== + function cnode_get_kind(ptr) result(n) + type(pm_ptr),intent(in):: ptr + integer:: n + if(pm_debug_checks) call check_cnode(ptr,0) + n=ptr%data%ptr(ptr%offset+1)%offset + end function cnode_get_kind + + !======================================== + ! Return number of arguments of a cnode + !======================================== + function cnode_numargs(ptr) result(n) + type(pm_ptr),intent(in):: ptr + integer:: n + if(debug_cnodes) call check_cnode(ptr,0) + n=pm_fast_esize(ptr)-cnode_args+1 + contains + include 'fesize.inc' + end function cnode_numargs + + + !======================================== + ! Does a cblock contain any communicating + ! operations? + !======================================== + function cblock_has_comm(cblock) result(ok) + type(pm_ptr):: cblock + logical:: ok + ok=(iand(cnode_get_num(cblock,cblock_flags),& + cblock_is_comm)/=0) + end function cblock_has_comm + + + subroutine print_all_sigs(context,iunit,sig_cache,proc_cache) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: sig_cache,proc_cache + integer:: i + + do i=1,pm_dict_size(context,proc_cache) + call print_sig(context,iunit,sig_cache,proc_cache,i) + enddo + + end subroutine print_all_sigs + + subroutine print_sig(context,iunit,sig_cache,proc_cache,n) + type(pm_context),pointer:: context + integer,intent(in):: iunit,n + type(pm_ptr),intent(in):: sig_cache,proc_cache + integer:: kind,i + type(pm_ptr):: cnode,key + key=pm_dict_key(context,proc_cache,int(n,pm_ln)) + cnode=pm_dict_val(context,proc_cache,int(n,pm_ln)) + if(pm_fast_vkind(cnode)==pm_pointer) then + kind=cnode_get_kind(cnode) + !write(*,*) 'KinD=',kind + select case(kind) + case(cnode_is_resolved_proc) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//& + trim(pm_name_as_string(context,& + cnode_get_name(cnode_arg(cnode,1),pr_name)))//' {' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_recursive)) & + write(iunit,'(a)') ' [recursive]' + if(cnode_flags_set(cnode,cnode_args+2,proc_unfinished)) & + write(iunit,'(a)') ' [unfinished]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_impure)) & + write(iunit,'(a)') ' [impure]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_inlinable)) & + write(iunit,'(a)') ' [not inlinable]' + if(cnode_flags_set(cnode,cnode_args+2,proc_has_for)) & + write(iunit,'(a)') ' [has for]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_pure_each)) & + write(iunit,'(a)') ' [not pure each]' + if(cnode_flags_set(cnode,cnode_args+2,proc_has_vkeys)) & + write(iunit,'(a)') ' [has vkeys]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_dcomm)) & + write(iunit,'(a)') ' [dcomm]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_file)) & + write(iunit,'(a)') ' [file]' + if(cnode_flags_set(cnode,cnode_args+2,proc_needs_par)) & + write(iunit,'(a)') ' [needs par]' + call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& + sig_cache,cnode_arg(cnode,1)) + write(iunit,'(a)') '}' + case(cnode_is_arglist) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'{' + if(cnode_flags_set(cnode,cnode_args+1,proc_is_var)) then + do i=5,cnode_numargs(cnode),2 + write(iunit,'(a)') trim(pm_name_as_string(context,& + cnode_get_name(cnode,cnode_args+i-1)))//' --> ['//& + trim(pm_int_as_string(cnode_get_num(cnode,cnode_args+i)))//']' + enddo + else + do i=3,cnode_numargs(cnode),2 + write(iunit,'(a)') ' '//& + trim(pm_name_as_string(context,& + key%data%i(key%offset+pm_fast_esize(key))))//& + trim(pm_type_as_string(context,& + cnode_num_arg(cnode,i)))//' {' + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode_arg(cnode,i+1)) + write(iunit,'(a)') ' }' + enddo + endif + write(iunit,'(a)') '}' + case(cnode_is_any_sig) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Any{' + do i=1,cnode_numargs(cnode) + call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) + enddo + write(iunit,'(a)') '}' + case(cnode_is_autoconv_sig) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Auto {' + do i=1,cnode_numargs(cnode) + call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) + enddo + write(iunit,'(a)') '}' + end select + else + call pm_dump_tree(context,iunit,cnode,1) + endif + contains + include 'fesize.inc' + include 'fvkind.inc' + end subroutine print_sig + + subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + integer:: flags + if(cnode_get_kind(cnode)==cnode_is_builtin) then + write(iunit,'(a)') ' Builtin '//& + op_names(cnode_get_num(cnode,cnode_args))//& + pm_int_as_string(cnode_get_num(cnode,cnode_args+1))//'{' + if(.not.pm_fast_isnull(cnode_get(cnode,bi_rcode))) then + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,bi_rcode),4) + endif + write(iunit,'(a)') ' }' + else + write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & + ' [nargs=',& + cnode_get_num(cnode,pr_nargs),',nkeys=',& + cnode_get_num(cnode,pr_nkeys),',nret=',cnode_get_num(cnode,pr_nret),& + ',ncalls=',cnode_get_num(cnode,pr_ncalls),']' + if(cnode_flags_set(cnode,pr_flags,proc_is_comm)) & + write(iunit,'(a)') ' [loop]' + if(cnode_flags_set(cnode,pr_flags,proc_is_each_proc)) & + write(iunit,'(a)') ' [each]' + if(cnode_flags_set(cnode,pr_flags,proc_is_dup_each)) & + write(iunit,'(a)') ' [dup-each]' + if(cnode_flags_set(cnode,pr_flags,proc_is_thru_each)) & + write(iunit,'(a)') ' [thru-each]' + if(cnode_flags_set(cnode,pr_flags,proc_is_empty_each)) & + write(iunit,'(a)') ' [empty-each]' + flags=cnode_get_kind(cnode) + !write(*,*) 'Kind=',flags + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_arg(cnode,1),4) + endif + contains + include 'fisnull.inc' + end subroutine print_proc_cnode + + subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,depth + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + type(pm_ptr)::p + p=cnode_get(cnode,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + call print_call_cnode(context,iunit,rvec,sig_cache,p,depth) + p=cnode_get(p,call_link) + enddo + contains + include 'fisnull.inc' + end subroutine print_cblock_cnode + + subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,depth + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + integer:: signo,name,i,j,k,nret,nargs,modl,line + type(pm_ptr):: p,args,amps + character(len=120):: str,location + signo=cnode_get_num(cnode,call_sig) + if(signo<0) then + str=repeat(' ',depth)//pm_name_as_string(context,-signo) + i=len_trim(str)+1 + if(.not.pm_fast_isnull(rvec)) then + k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) + if(k>=0) then + call append_to_line(iunit,str,i,& + '['//trim(pm_int_as_string(k))//'] ',.false.,depth) + endif + endif + else + p=pm_dict_key(context,sig_cache,& + int(signo,pm_ln)) + name=p%data%i(p%offset+pm_fast_esize(p)) + if(.not.pm_fast_isnull(cnode_get(cnode,call_var))) then + str=repeat(' ',depth)//'call *(' + i=depth+7 + call print_value_cnode(context,iunit,rvec,sig_cache,& + cnode_get(cnode,call_var),depth,str,i) + call append_to_line(iunit,str,i,') ',.false.,depth) + elseif(pm_fast_isnull(rvec)) then + str=repeat(' ',depth)//'call '//pm_name_as_string(context,name) + else + k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) + if(k==spsig_thru) then + str=repeat(' ',depth)//'call [thru]'//& + pm_name_as_string(context,name) + elseif(k==spsig_dup) then + str=repeat(' ',depth)//'call [dup]'//& + pm_name_as_string(context,name) + elseif(k==spsig_noop) then + str=repeat(' ',depth)//'call [noop]'//& + pm_name_as_string(context,name) + elseif(k<0) then + str=repeat(' ',depth)//'call [??]'//& + pm_name_as_string(context,name) + else + str=repeat(' ',depth)//'call '//'['//trim(pm_int_as_string(k))//']'& + //pm_name_as_string(context,name) + endif + endif + i=len_trim(str) + call append_proc_call_flags(iunit,str,i,cnode_get_num(cnode,call_flags),.false.,depth) + i=i+1 + end if + + args=cnode_get(cnode,call_args) + nargs=cnode_numargs(args) + nret=cnode_get_num(cnode,call_nret) + amps=cnode_get(cnode,call_amp) + amps=pm_name_val(context,int(amps%offset)) + + if(nret>0) then + do j=1,nret + call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) + i=i+1 + enddo + call append_to_line(iunit,str,i,'<- ',.false.,depth) + endif + k=0 + do j=nret+1,nargs + if(.not.pm_fast_isnull(amps)) then + if(amps%data%i(amps%offset+k)==i-nret) then + call append_to_line(iunit,str,i,'&',.false.,depth) + k=min(k+1,pm_fast_esize(amps)) + endif + endif + call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) + i=i+1 + enddo + modl=cnode_get_num(cnode,cnode_modl_name) + line=cnode_get_num(cnode,cnode_lineno) + location=trim(pm_name_as_string(context,modl))//':'//pm_int_as_string(line) + str(len(str)-len_trim(location)+1:)=location + write(iunit,'(a)') str + + contains + include 'fesize.inc' + include 'fisnull.inc' + end subroutine print_call_cnode + + subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) + type(pm_context),pointer:: context + integer,intent(in):: iunit,depth + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + character(len=*),intent(inout):: str + integer,intent(inout):: i + integer:: kind,name,tno + kind=pm_fast_vkind(cnode) + if(kind==pm_tiny_int) then + call append_to_line(iunit,str,i,& + trim(pm_int_as_string(int(cnode%offset))),.false.,depth) + elseif(kind==pm_null) then + call append_to_line(iunit,str,i,& + 'NULL',.false.,depth) + elseif(kind==pm_name) then + call append_to_line(iunit,str,i,& + "'"//trim(pm_name_as_string(context,int(cnode%offset))),.false.,depth) + elseif(kind==pm_type) then + call append_to_line(iunit,str,i,& + '<'//trim(pm_type_as_string(context,int(cnode%offset)))//'>',.false.,depth) + else + kind=cnode_get_kind(cnode) + select case(kind) + case(cnode_is_var) + name=cnode_get_num(cnode,var_name) + if(name==0) then + call append_to_line(iunit,str,i,'#'//& + trim(pm_int_as_string(cnode_get_num(cnode,var_index))),.false.,depth) + else + call append_quoted_to_line(iunit,str,i,& + trim(pm_name_as_string(context,name)),.false.,depth) + endif + if(.not.pm_fast_isnull(rvec)) then + tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) + call append_to_line(iunit,str,i,& + '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) + endif + case(cnode_is_const) + call append_to_line(iunit,str,i,& + trim(pm_value_as_string(context,cnode_arg(cnode,1))),.false.,depth) + case(cnode_is_cblock) + call append_to_line(iunit,str,i,'{',.true.,depth) + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,min(50,depth+2)) + str=' ' + str(depth+1:depth+1)='}' + i=depth+1 + end select + endif + contains + include 'fvkind.inc' + include 'fisnull.inc' + end subroutine print_value_cnode + + subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + integer,intent(in):: flags + logical,intent(in):: proc_flags + integer,intent(in):: depth + if(iand(flags,call_is_comm)/=0) then + call append_to_line(iunit,str,i,'%',.false.,depth) + endif + if(flags/=iand(flags,call_is_comm)) then + call append_to_line(iunit,str,i,'<',.false.,depth) + if(iand(flags,proc_run_complete)/=0) then + call append_to_line(iunit,str,i,'C',.false.,depth) + endif + if(iand(flags,proc_run_local)/=0) then + call append_to_line(iunit,str,i,'L',.false.,depth) + endif + if(iand(flags,proc_run_shared)/=0) then + call append_to_line(iunit,str,i,'S',.false.,depth) + endif + if(iand(flags,proc_run_always)/=0) then + call append_to_line(iunit,str,i,'A',.false.,depth) + endif + if(iand(flags,proc_inline)/=0) then + call append_to_line(iunit,str,i,'I',.false.,depth) + endif + if(iand(flags,proc_no_inline)/=0) then + call append_to_line(iunit,str,i,'N',.false.,depth) + endif + if(proc_flags) then + if(iand(flags,proc_is_open)/=0) then + call append_to_line(iunit,str,i,'o',.false.,depth) + endif + if(iand(flags,proc_is_each_proc)/=0) then + call append_to_line(iunit,str,i,'e',.false.,depth) + endif + if(iand(flags,proc_is_cond)/=0) then + call append_to_line(iunit,str,i,'c',.false.,depth) + endif + if(iand(flags,proc_is_uncond)/=0) then + call append_to_line(iunit,str,i,'u',.false.,depth) + endif + if(iand(flags,proc_is_abstract)/=0) then + call append_to_line(iunit,str,i,'a',.false.,depth) + endif + else + if(iand(flags,call_is_fixed)/=0) then + call append_to_line(iunit,str,i,'f',.false.,depth) + endif + if(iand(flags,call_is_assign_call)/=0) then + call append_to_line(iunit,str,i,'a',.false.,depth) + endif + if(iand(flags,call_is_vararg)/=0) then + call append_to_line(iunit,str,i,'v',.false.,depth) + endif + if(iand(flags,call_inline_when_compiling)/=0) then + call append_to_line(iunit,str,i,'i',.false.,depth) + endif + if(iand(flags,call_dup_result)/=0) then + call append_to_line(iunit,str,i,'d',.false.,depth) + endif + if(iand(flags,call_is_cond)/=0) then + call append_to_line(iunit,str,i,'c',.false.,depth) + endif + if(iand(flags,call_is_no_touch)/=0) then + call append_to_line(iunit,str,i,'n',.false.,depth) + endif + if(iand(flags,call_is_unlabelled)/=0) then + call append_to_line(iunit,str,i,'u',.false.,depth) + endif + endif + call append_to_line(iunit,str,i,'>',.false.,depth) + end if + end subroutine append_proc_call_flags + + subroutine append_quoted_to_line(iunit,str,i,part,break,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + character(len=*),intent(in):: part + logical,intent(in):: break + integer,intent(in):: depth + integer:: first + first=iachar(part(1:1)) + if(first>=iachar('a').and.first<=iachar('z').or.& + first>=iachar('A').and.first<=iachar('Z')) then + call append_to_line(iunit,str,i,part,break,depth) + else + call append_to_line(iunit,str,i,"'"//trim(part)//"'",break,depth) + endif + end subroutine append_quoted_to_line + + subroutine append_to_line(iunit,str,i,part,break,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + character(len=*),intent(in):: part + logical,intent(in):: break + integer,intent(in):: depth + integer:: n + n=len(part) + if(i+n>len(str)) then + write(iunit,'(a)') str(1:min(len(str),i)) + str=repeat(' ',depth+1)//part(1:min(len(str)-depth-1,n)) + i=depth+1+n + else + str(i+1:i+n)=part(1:n) + i=i+n + endif + if(break.or.i>len(str)) then + write(iunit,'(a)') str(1:i) + i=1 + endif + end subroutine append_to_line + + +end module pm_cnodes diff --git a/src/codegen.f90 b/src/codegen.f90 index af45350..cd7ef9c 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -51,8 +51,9 @@ module pm_codegen use pm_lib use pm_symbol use pm_types - use pm_parser + use pm_ast use pm_sysdefs + use pm_cnodes implicit none logical,parameter:: debug_codegen=.false. @@ -68,132 +69,6 @@ module pm_codegen integer,parameter:: max_type_nesting=64 integer,parameter:: max_error_nodes=1024 - ! Magic number for code tree nodes - integer,parameter:: cnode_magic_no=10456_pm_p - - ! Offsets common to all cnode structures - integer,parameter:: cnode_magic=0 - integer,parameter:: cnode_kind=1 - integer,parameter:: cnode_modl_name=2 - integer,parameter:: cnode_lineno=3 - integer,parameter:: cnode_charno=4 - integer,parameter:: cnode_args=5 - - ! Types of cnode structure - integer,parameter:: cnode_is_cblock=1 - integer,parameter:: cnode_is_var=2 - integer,parameter:: cnode_is_const=3 - integer,parameter:: cnode_is_call=4 - integer,parameter:: cnode_is_arglist=5 - integer,parameter:: cnode_is_builtin=6 - integer,parameter:: cnode_is_proc=7 - integer,parameter:: cnode_is_resolved_proc=8 - integer,parameter:: cnode_is_arg_constraint=9 - integer,parameter:: cnode_is_par_constraint=10 - integer,parameter:: cnode_is_type_constraint=11 - !integer,parameter:: cnode_is_interface_constraint=12 - integer,parameter:: cnode_is_any_sig=13 - integer,parameter:: cnode_is_autoconv_sig=14 - integer,parameter:: cnode_num_kinds=14 - - ! Offsets into cblock cnodes - integer,parameter:: cblock_parent=cnode_args+0 - integer,parameter:: cblock_first_var=cnode_args+1 - integer,parameter:: cblock_last_var=cnode_args+2 - integer,parameter:: cblock_first_call=cnode_args+3 - integer,parameter:: cblock_last_call=cnode_args+4 - integer,parameter:: cblock_sym=cnode_args+5 - integer,parameter:: cblock_start=cnode_args+6 - integer,parameter:: cblock_flags=cnode_args+7 - integer,parameter:: cblock_index=cnode_args+8 - integer,parameter:: cblock_last_loop_call=cnode_args+9 - integer,parameter:: cblock_var_inits=cnode_args+10 - integer,parameter:: cblock_node_size=11 - - ! Flags for cblocks - integer,parameter:: cblock_is_comm=1 - integer,parameter:: cblock_is_open=2 - - ! Offsets into call cnodes - integer,parameter:: call_args=cnode_args+0 - integer,parameter:: call_parent=cnode_args+1 - integer,parameter:: call_sig=cnode_args+2 - integer,parameter:: call_flags=cnode_args+3 - integer,parameter:: call_link=cnode_args+4 - integer,parameter:: call_nret=cnode_args+5 - integer,parameter:: call_nkeys=cnode_args+6 - integer,parameter:: call_index=cnode_args+7 - integer,parameter:: call_par_depth=cnode_args+8 - integer,parameter:: call_var=cnode_args+9 - integer,parameter:: call_amp=cnode_args+10 - integer,parameter:: call_node_size=11 - - ! Flags for call nodes - ! (call_is_comm=1.. defined in parser) - integer,parameter:: call_is_fixed = 2**10 - integer,parameter:: call_is_assign_call = 2**11 - integer,parameter:: call_is_vararg = 2**12 - integer,parameter:: call_inline_when_compiling = 2**13 - integer,parameter:: call_dup_result = 2**14 - integer,parameter:: call_is_cond = 2**15 - integer,parameter:: call_is_no_touch = 2**16 - integer,parameter:: call_is_unlabelled = 2**17 - - ! Offsets into var cnodes - integer,parameter:: var_parent=cnode_args+0 - integer,parameter:: var_name=cnode_args+1 - integer,parameter:: var_flags=cnode_args+2 - integer,parameter:: var_link=cnode_args+3 - integer,parameter:: var_index=cnode_args+4 - integer,parameter:: var_par_depth=cnode_args+5 - integer,parameter:: var_create_depth = cnode_args + 6 - integer,parameter:: var_node_size=7 - integer,parameter:: var_extra_info=cnode_args+7 - - ! Flags for var cnodes - integer,parameter:: var_is_var=1 - integer,parameter:: var_is_ref=2 - integer,parameter:: var_is_param=4 - integer,parameter:: var_is_shadowed=16 - integer,parameter:: var_is_imported=32 - integer,parameter:: var_is_accessed=64 - integer,parameter:: var_is_changed=128 - integer,parameter:: var_is_multi_access=256 - integer,parameter:: var_is_key=512 - integer,parameter:: var_is_varg=1024 - integer,parameter:: var_is_par_var=2048 - integer,parameter:: var_is_incomplete=4096 - integer,parameter:: var_is_aliased=8192 - integer,parameter:: var_is_not_inited=16384 - integer,parameter:: var_is_no_import_export=32768 - integer,parameter:: var_is_sync=65536 - - ! Offsets into proc nodes - integer,parameter:: pr_cblock=cnode_args+0 - integer,parameter:: pr_max_index=cnode_args+1 - integer,parameter:: pr_recurse=cnode_args+2 - integer,parameter:: pr_id=cnode_args+3 - integer,parameter:: pr_rtype=cnode_args+4 ! Must be same as bi_rtype - integer,parameter:: pr_nargs=cnode_args+5 - integer,parameter:: pr_nkeys=cnode_args+6 - integer,parameter:: pr_nret=cnode_args+7 - integer,parameter:: pr_flags=cnode_args+8 - integer,parameter:: pr_name=cnode_args+9 - integer,parameter:: pr_ncalls=cnode_args+10 - integer,parameter:: pr_tkeys=cnode_args+11 - integer,parameter:: pr_node_size=12 - - ! Offsets into builtin nodes - integer,parameter:: bi_opcode=cnode_args+0 - integer,parameter:: bi_opcode2=cnode_args+1 - integer,parameter:: bi_data=cnode_args+2 - integer,parameter:: bi_flags=cnode_args+3 - integer,parameter:: bi_rtype=cnode_args+4 ! Must be same as pr_rtype - integer,parameter:: bi_rcode=cnode_args+5 - integer,parameter:: bi_rsym=cnode_args+6 - integer,parameter:: bi_id=cnode_args+7 - integer,parameter:: bi_node_size=8 - ! Parallel status of a value integer,parameter:: value_is_shared=0 integer,parameter:: value_is_private=1 @@ -321,6 +196,9 @@ module pm_codegen ! Counter to provide unique index for all nodes created integer:: index + ! Nesting depth of if statements (offset into vstack) + integer:: if_scope + ! Flags indicating type inference not complete logical:: types_finished,redo_calls,incomplete,first_pass @@ -387,6 +265,7 @@ subroutine init_coder(context,coder,visibility) coder%loop_cblock=pm_null_obj coder%proc_keys=pm_null_obj coder%index=0 + coder%if_scope=0 coder%true=pm_new_small(context,pm_logical,1_pm_p) coder%true%data%l(coder%true%offset)=.true. coder%false=pm_new_small(context,pm_logical,1_pm_p) @@ -533,6 +412,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& select case(sym) case(sym_if) save_par_state=coder%par_state + j=push_if_scope(coder) call trav_xexpr(coder,cblock,node,& node_arg(node,1)) if(coder%par_state>par_state_outer) then @@ -542,6 +422,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& coder%par_state=par_state_cond endif endif + coder%if_scope=j call trav_stmt_list(coder,cblock,node,& node_arg(node,2),sym_if) if(.not.pm_fast_isnull(node_arg(node,3))) then @@ -550,17 +431,21 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif + n=get_if_scope(coder) call make_sp_call(coder,cblock,node,& - sym_if,3,0) + sym_if,3+n,0) + call pop_if_scope(coder) coder%par_state=save_par_state case(sym_if_invar) if(coder%par_state>=par_state_cond) then call code_error(coder,node,& 'Cannot have "if invar" in a conditional context') endif + j=push_if_scope(coder) call trav_xexpr(coder,cblock,node,& node_arg(node,1)) call code_check_invar(coder,cblock,node,top_code(coder)) + coder%if_scope=j call trav_stmt_list(coder,cblock,node,& node_arg(node,2),sym_if_invar) if(.not.pm_fast_isnull(node_arg(node,3))) then @@ -569,7 +454,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif - call make_sp_call(coder,cblock,node,sym,3,0) + n=get_if_scope(coder) + call make_sp_call(coder,cblock,node,sym,3+n,0) + call pop_if_scope(coder) case(sym_switch) save_par_state=coder%par_state call trav_xexpr(coder,cblock,node,& @@ -882,6 +769,105 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& include 'fisnull.inc' include 'fname.inc' end subroutine trav_open_stmt_list + + !=================================== + ! Create a new scope for an if + ! statement (used to identify + ! variables defined outside the + ! statement that are modified + ! within it) + ! Pushes small record on vstack + !=================================== + function push_if_scope(coder) result(new_if_scope) + type(code_state),intent(inout):: coder + integer:: new_if_scope + call code_num(coder,coder%if_scope) + call code_null(coder) + new_if_scope=coder%vtop + end function push_if_scope + + !================================== + ! Get the changes if current if-scope + !================================== + function get_if_scope(coder) result(n) + type(code_state),intent(inout):: coder + integer:: n + call retrieve_change_list(coder,coder%vstack(coder%if_scope),n) + end function get_if_scope + + !================================ + ! Exit if-statement scope + !================================ + subroutine pop_if_scope(coder) + type(code_state),intent(inout):: coder + coder%if_scope=coder%vstack(coder%vtop-1)%offset + call drop_code(coder) + call drop_code(coder) + end subroutine pop_if_scope + + !============================================= + ! Add var to the change list for all if scopes + ! that are nested inside the scope in which + ! the variable was defined + !============================================= + subroutine update_change_lists(coder,var) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: var + integer:: if_scope + if_scope=coder%if_scope + do while(cnode_get_num(var,var_if_scope)=coder%par_depth) then iblock=cblock else @@ -2741,7 +2742,7 @@ subroutine check_par_nesting(coder,list_head,node,cond_is_ok) list=list_head i=cnode_get_num(list,cblock_sym) do - call cnode_set(coder,list,cblock_last_loop_call,& + call cnode_set(coder%context,list,cblock_last_loop_call,& cnode_get(list,cblock_last_call)) if(i==sym_for.or.i==sym_for_stmt.or.i==sym_nhd) then exit @@ -2931,7 +2932,7 @@ subroutine trav_sync_assign(coder,cblock,pnode,node) call make_op_assignment_noalias(coder,cblock,node,node_arg(node,2),node_arg(node,3)) endif ! Null out link to node to prevent retaining link to module - call cnode_set(coder,coder%var(base+1),var_extra_info,pm_null_obj) + call cnode_set(coder%context,coder%var(base+1),var_extra_info,pm_null_obj) call pop_vars_to(coder,base) coder%par_state=save_par_state end subroutine trav_sync_assign @@ -3186,6 +3187,7 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,mode,avar) 'Cannot assign to constant: ',name) else call cnode_set_flags(var,var_flags,var_is_changed) + call update_change_lists(coder,var) endif endif if(iand(flags,var_is_not_inited)/=0) then @@ -5936,7 +5938,7 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& integer:: save_proc_base,& save_par_base, save_over_base,save_proc_par_depth,& save_proc_nret,save_par_state,save_proc_ncalls,& - save_subs_index,save_run_mode,save_run_flags + save_subs_index,save_if_scope,save_run_mode,save_run_flags type(pm_ptr):: save_sub_array,save_loop_cblock, & save_proc_keys,save_label logical:: save_aliased,save_in_sync @@ -5945,7 +5947,7 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& type(pm_reg),pointer:: reg logical:: complete,old_complete integer,save:: pdepth=0 - + if(debug_codegen) then write(*,*) repeat(' ',pdepth),'TRAV PROC>',& trim(pm_name_as_string(coder%context,& @@ -5959,14 +5961,14 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& else nkeyargs=pm_set_size(coder%context,keyargs) endif - + ! Parameter types wbase=coder%wtop obase=coder%vtop partyp=proc_param_type(coder,node) call code_num(coder,int(partyp)) if(coder%wtop/=wbase) call pm_panic('par type wstack mismatch') - + sym=node_sym(node) if(sym==sym_builtin) then @@ -6047,17 +6049,17 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& write(70,*) trim(pm_name_as_string(coder%context,& node_get_num(node,proc_name))),'par',coder%par_state old_complete=coder%par_statepm_register(coder%context,'tproc',tkeys) - + ! Different types of procedure npars=0 flags=node_get_num(node,proc_flags) @@ -6123,7 +6125,7 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& write(70,*) trim(pm_name_as_string(coder%context,& node_get_num(node,proc_name))),pr_flags,complete,old_complete,coder%par_state - + ! Create proc code object call code_num(coder,coder%index) ! Maximum index call code_num(coder,0) ! Recursion flag @@ -6139,7 +6141,7 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& call code_num(coder,coder%proc_ncalls) ! Number of calls call code_val(coder,tkeys) ! Keyword arg info call make_code(coder,node,cnode_is_proc,pr_node_size) - + call pm_delete_register(coder%context,reg) call pop_par_scope(coder,cblock,node) @@ -6155,7 +6157,7 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& node_get_num(node,proc_name))),coder%wtop,coder%top !call dump_parse_tree(coder%context,6,node,2) endif - + contains include 'fisnull.inc' include 'fistiny.inc' @@ -6167,59 +6169,62 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& include 'fvkind.inc' subroutine save_proc_state - save_index=coder%index - save_proc_base=coder%proc_base - save_proc_ncalls=coder%proc_ncalls - save_par_base=coder%par_base - save_over_base=coder%over_base - save_loop_cblock=coder%loop_cblock - save_proc_keys=coder%proc_keys - save_proc_par_depth=coder%proc_par_depth - save_proc_nret=coder%proc_nret - save_par_state=coder%par_state - save_label=coder%label - save_subs_index=coder%subs_index - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - save_aliased=coder%aliased - save_in_sync=coder%in_sync + save_index=coder%index + save_if_scope=coder%if_scope + save_proc_base=coder%proc_base + save_proc_ncalls=coder%proc_ncalls + save_par_base=coder%par_base + save_over_base=coder%over_base + save_loop_cblock=coder%loop_cblock + save_proc_keys=coder%proc_keys + save_proc_par_depth=coder%proc_par_depth + save_proc_nret=coder%proc_nret + save_par_state=coder%par_state + save_label=coder%label + save_subs_index=coder%subs_index + save_run_mode=coder%run_mode + save_run_flags=coder%run_flags + save_aliased=coder%aliased + save_in_sync=coder%in_sync end subroutine save_proc_state subroutine init_proc_state - coder%index=0 - coder%proc_base=coder%top - coder%proc_ncalls=0 - coder%par_base=coder%top - coder%over_base=coder%top+2 - coder%proc_keys=keyargs - coder%proc_par_depth=coder%par_depth - coder%proc_nret=nret - coder%par_state=par_state_outer - coder%run_mode=sym_complete - coder%subs_index=-1 - coder%run_flags=0 - coder%aliased=.false. - coder%in_sync=.false. + coder%index=0 + coder%if_scope=0 + coder%proc_base=coder%top + coder%proc_ncalls=0 + coder%par_base=coder%top + coder%over_base=coder%top+2 + coder%proc_keys=keyargs + coder%proc_par_depth=coder%par_depth + coder%proc_nret=nret + coder%par_state=par_state_outer + coder%run_mode=sym_complete + coder%subs_index=-1 + coder%run_flags=0 + coder%aliased=.false. + coder%in_sync=.false. end subroutine init_proc_state - subroutine restore_proc_state - coder%index=save_index - coder%proc_base=save_proc_base - coder%proc_ncalls=save_proc_ncalls - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%loop_cblock=save_loop_cblock - coder%proc_keys=save_proc_keys - coder%par_depth=coder%proc_par_depth - coder%proc_par_depth=save_proc_par_depth - coder%proc_nret=save_proc_nret - coder%par_state=save_par_state - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - coder%label=save_label - coder%subs_index=save_subs_index - coder%aliased=save_aliased - coder%in_sync=save_in_sync + subroutine restore_proc_state + coder%index=save_index + coder%if_scope=save_if_scope + coder%proc_base=save_proc_base + coder%proc_ncalls=save_proc_ncalls + coder%par_base=save_par_base + coder%over_base=save_over_base + coder%loop_cblock=save_loop_cblock + coder%proc_keys=save_proc_keys + coder%par_depth=coder%proc_par_depth + coder%proc_par_depth=save_proc_par_depth + coder%proc_nret=save_proc_nret + coder%par_state=save_par_state + coder%run_mode=save_run_mode + coder%run_flags=save_run_flags + coder%label=save_label + coder%subs_index=save_subs_index + coder%aliased=save_aliased + coder%in_sync=save_in_sync end subroutine restore_proc_state subroutine code_params(cblock,iscomm) @@ -6325,7 +6330,7 @@ subroutine check_param_modes(mode,flag_sym) endif enddo end subroutine check_param_modes - + recursive subroutine code_keys(cblock,tkeys) type(pm_ptr),intent(in):: cblock type(pm_ptr),intent(inout):: tkeys @@ -6392,10 +6397,10 @@ end subroutine code_check recursive subroutine code_body(cblock) type(pm_ptr),intent(in):: cblock ! Body of statements - p=node_get(node,proc_stmts) - if(.not.pm_fast_isnull(p)) then - call trav_open_stmt_list(coder,cblock,node,p) - endif + p=node_get(node,proc_stmts) + if(.not.pm_fast_isnull(p)) then + call trav_open_stmt_list(coder,cblock,node,p) + endif end subroutine code_body recursive subroutine code_result(cblock,flags) @@ -6403,7 +6408,7 @@ recursive subroutine code_result(cblock,flags) integer,intent(in):: flags type(pm_ptr):: p,q integer:: status,i,j - + ! Result expression p=node_get(node,proc_result) if(.not.pm_fast_isnull(p)) then @@ -6423,21 +6428,21 @@ recursive subroutine code_result(cblock,flags) sym_result,nret,0) rsig=pop_word(coder) if(pm_debug_checks) then - if(coder%vtop/=base) then - write(*,*) '***************',nret - do i=base+1,coder%vtop - call qdump_code_tree(coder,pm_null_obj,6,& - coder%vstack(i),2) - enddo - write(*,*) coder%vtop,base - write(*,*) '%%%%%%%%%%%%' - call dump_parse_tree(coder%context,6,p,2) - call pm_panic('rtn mismatch') - endif - endif - else - rsig=0 - endif + if(coder%vtop/=base) then + write(*,*) '***************',nret + do i=base+1,coder%vtop + call qdump_code_tree(coder,pm_null_obj,6,& + coder%vstack(i),2) + enddo + write(*,*) coder%vtop,base + write(*,*) '%%%%%%%%%%%%' + call dump_parse_tree(coder%context,6,p,2) + call pm_panic('rtn mismatch') + endif + endif + else + rsig=0 + endif end subroutine code_result ! This sets up a par-loop structure for comm proc @@ -6445,15 +6450,15 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) type(pm_ptr),intent(in):: cblock type(pm_ptr),intent(out):: cblock2,cblock3 integer:: iter - + !coder%over_base=coder%top call push_var(coder,sym_for,& coder%var(loop_pars+1)) - - + + call make_sys_var(coder,cblock,node,sym_in,0) - + iter=coder%top coder%par_base=iter call make_sys_var(coder,cblock,node,sym_pling,var_is_shadowed) @@ -6465,29 +6470,29 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) cblock2=make_cblock(coder,cblock,node,sym_proc) coder%loop_cblock=cblock2 call drop_code(coder) - + ! Alias the region and subregion variables call push_var(coder,sym_region,coder%var(iter+lv_distr)) call push_var(coder,sym_subregion,coder%var(loop_pars+2)) coder%over_base =coder%top - + call push_par_scope(coder,cblock2) call push_var(coder,sym_here_in_tile,coder%var(loop_pars+3)) call make_sys_var(coder,cblock2,node,sym_here,var_is_shadowed) call code_val(coder,coder%var(iter+lv_tile)) call code_val(coder,coder%var(iter+lv_index)) call make_sys_call(coder,cblock2,node,sym_get_element,2,1) - + !!$ if(iter+lv_here/=coder%top) then !!$ write(*,*) '#',iter+lv_here,coder%top !!$ call pm_panic('iter mismatch in code_loop_startup') !!$ endif - + coder%par_state=par_state_for coder%run_mode=sym_complete - + coder%par_state=merge(par_state_for,par_state_masked,complete) - + if(complete) pr_flags=ior(pr_flags,proc_run_complete) cblock3=make_cblock(coder,cblock2,node,sym_for_stmt) @@ -6502,7 +6507,7 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) call make_basic_sys_call(coder,cblock3,node,sym_nested_loop,1,0,& coder%par_depth-1,call_inline_when_compiling) endif - + end subroutine code_loop_startup subroutine code_loop_finish(cblock,cblock2,cblock3) @@ -7739,6 +7744,7 @@ subroutine make_temp_var(coder,cblock,node) pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) call code_val(coder,& pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) + call code_num(coder,coder%if_scope) call make_code(coder,node,cnode_is_var,var_node_size) link=cnode_get(cblock,cblock_last_var) if(pm_fast_isnull(link)) then @@ -7830,6 +7836,7 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) coder%par_depth-coder%proc_par_depth)) call code_val(coder,pm_fast_tinyint(coder%context,& coder%par_depth-coder%proc_par_depth)) + call code_num(coder,coder%if_scope) if(present(extra_info)) then call code_val(coder,extra_info) call make_code(coder,node,cnode_is_var,var_node_size+1) @@ -8265,10 +8272,10 @@ subroutine close_cblock(coder,cblock) endif p=cnode_get(cblock,cblock_last_loop_call) if(pm_fast_isnull(p)) then - call cnode_set(coder,cblock,cblock_last_loop_call,& + call cnode_set(coder%context,cblock,cblock_last_loop_call,& cnode_get(cblock,cblock_first_call)) else - call cnode_set(coder,cblock,cblock_last_loop_call,& + call cnode_set(coder%context,cblock,cblock_last_loop_call,& cnode_get(p,call_link)) endif contains @@ -8548,242 +8555,8 @@ function top_word(coder) result(k) k=coder%wstack(coder%wtop) end function top_word - !================================= - ! Check cnode (debugging) - !================================= - subroutine check_cnode(ptr,n) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer(pm_p):: m - if(.not.pm_fast_vkind(ptr)==pm_pointer) then - write(*,*) 'vKind=',ptr%data%vkind - call pm_panic('cnode not ptr') - endif - if(ptr%data%ptr(ptr%offset)%offset/=cnode_magic_no) then - call pm_panic('bad cnode magic no') - endif - m=ptr%data%ptr(ptr%offset+1)%offset - if(m<1.or.m>cnode_num_kinds) & - call pm_panic('cnode bad kind') - if(n<0.or.n>pm_fast_esize(ptr)) & - call pm_panic('bad cnode offset') - contains - include 'fvkind.inc' - include 'fesize.inc' - end subroutine check_cnode - - !========================================== - ! Get argument n from cnode - !========================================== - function cnode_arg(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - type(pm_ptr):: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+cnode_args+n-1) - end function cnode_arg - - !====================================== - ! Get element n from cnode - !====================================== - function cnode_get(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - type(pm_ptr):: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n) - end function cnode_get - - !==================================== - ! Set element n of cnode - !==================================== - subroutine cnode_set(coder,ptr,n,val) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - type(pm_ptr),intent(in):: val - if(debug_codegen) call check_cnode(ptr,n) - call pm_ptr_assign(coder%context,ptr,int(n,pm_ln),val) - end subroutine cnode_set - - ! ======================================== - ! Get element n from cnode as a number - !========================================= - function cnode_get_num(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - end function cnode_get_num - - !============================================ - ! Get argument n from cnode as a number - !============================================ - function cnode_num_arg(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n+cnode_args-1)%offset - end function cnode_num_arg - - !========================================= - ! Get element n from cnode as a name - !========================================= - function cnode_get_name(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - end function cnode_get_name - - !========================================== - ! Set element n in cnode to a new number - ! (must be number already) - !========================================== - subroutine cnode_set_num(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - if(debug_codegen) call check_cnode(ptr,n) - ptr%data%ptr(ptr%offset+n)%offset=val - end subroutine cnode_set_num - - !========================================== - ! Increment argument n from cnode - !========================================== - subroutine cnode_incr_num(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - if(debug_codegen) call check_cnode(ptr,n) - ptr%data%ptr(ptr%offset+n)%offset=& - ptr%data%ptr(ptr%offset+n)%offset+val - end subroutine cnode_incr_num - - !============================================== - ! Set given flags in an element of a cnode - ! (bitwise or of existing number) - !============================================== - subroutine cnode_set_flags(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - type(pm_ptr):: p - if(debug_codegen) then - call check_cnode(ptr,n) - p=ptr%data%ptr(ptr%offset+n) - if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then - write(*,*) 'vkind=',pm_fast_vkind(ptr) - call pm_panic('Set flags') - endif - if(cnode_get_kind(ptr)==cnode_is_var.and.& - n/=var_flags.or.& - cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& - cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then - call pm_panic('set flags') - endif - endif - ptr%data%ptr(ptr%offset+n)%offset=ior(& - ptr%data%ptr(ptr%offset+n)%offset,int(val,pm_p)) - contains - include 'fvkind.inc' - end subroutine cnode_set_flags - - !============================================ - ! Clear flags in element of a code code - ! (Bitwise clear of exiting number) - !============================================ - subroutine cnode_clear_flags(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - type(pm_ptr):: p - if(debug_codegen) then - call check_cnode(ptr,n) - p=ptr%data%ptr(ptr%offset+n) - if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then - write(*,*) 'vkind=',pm_fast_vkind(ptr) - call pm_panic('Set flags') - endif - if(cnode_get_kind(ptr)==cnode_is_var.and.& - n/=var_flags.or.& - cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& - cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then - call pm_panic('set flags') - endif - endif - ptr%data%ptr(ptr%offset+n)%offset=iand(& - ptr%data%ptr(ptr%offset+n)%offset,not(int(val,pm_p))) - contains - include 'fvkind.inc' - end subroutine cnode_clear_flags - - !=================================================================== - ! Check all given flags in a given element of a cnode are clear - ! (bitwise and of extisting number and check for zero) - !=================================================================== - function cnode_flags_clear(ptr,n,flags) result(ok) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n,flags - logical:: ok - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - ok=iand(flags,val)==0 - end function cnode_flags_clear - - !============================================================ - ! Check all given flags in an element of a cnode are set - ! (bitwise and) - !============================================================ - function cnode_flags_set(ptr,n,flags) result(ok) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n,flags - logical:: ok - integer(pm_p):: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - ok=iand(flags,int(val))==flags - end function cnode_flags_set - - !========================================== - ! Return kind of a cnode - !========================================== - function cnode_get_kind(ptr) result(n) - type(pm_ptr),intent(in):: ptr - integer:: n - if(pm_debug_checks) call check_cnode(ptr,0) - n=ptr%data%ptr(ptr%offset+1)%offset - end function cnode_get_kind - - !======================================== - ! Return number of arguments of a cnode - !======================================== - function cnode_numargs(ptr) result(n) - type(pm_ptr),intent(in):: ptr - integer:: n - if(debug_codegen) call check_cnode(ptr,0) - n=pm_fast_esize(ptr)-cnode_args+1 - contains - include 'fesize.inc' - end function cnode_numargs - - !======================================== - ! Does a cblock contain any communicating - ! operations? - !======================================== - function cblock_has_comm(cblock) result(ok) - type(pm_ptr):: cblock - logical:: ok - ok=(iand(cnode_get_num(cblock,cblock_flags),& - cblock_is_comm)/=0) - end function cblock_has_comm - - + !===================================== ! Dump a cnode tree (debugging) !===================================== @@ -9004,409 +8777,6 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) include 'fisname.inc' end subroutine qdump_code_tree - subroutine print_all_sigs(context,iunit,sig_cache,proc_cache) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: sig_cache,proc_cache - integer:: i - - do i=1,pm_dict_size(context,proc_cache) - call print_sig(context,iunit,sig_cache,proc_cache,i) - enddo - - end subroutine print_all_sigs - - subroutine print_sig(context,iunit,sig_cache,proc_cache,n) - type(pm_context),pointer:: context - integer,intent(in):: iunit,n - type(pm_ptr),intent(in):: sig_cache,proc_cache - integer:: kind,i - type(pm_ptr):: cnode,key - key=pm_dict_key(context,proc_cache,int(n,pm_ln)) - cnode=pm_dict_val(context,proc_cache,int(n,pm_ln)) - if(pm_fast_vkind(cnode)==pm_pointer) then - kind=cnode_get_kind(cnode) - !write(*,*) 'KinD=',kind - select case(kind) - case(cnode_is_resolved_proc) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//& - trim(pm_name_as_string(context,& - cnode_get_name(cnode_arg(cnode,1),pr_name)))//' {' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_recursive)) & - write(iunit,'(a)') ' [recursive]' - if(cnode_flags_set(cnode,cnode_args+2,proc_unfinished)) & - write(iunit,'(a)') ' [unfinished]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_impure)) & - write(iunit,'(a)') ' [impure]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_inlinable)) & - write(iunit,'(a)') ' [not inlinable]' - if(cnode_flags_set(cnode,cnode_args+2,proc_has_for)) & - write(iunit,'(a)') ' [has for]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_pure_each)) & - write(iunit,'(a)') ' [not pure each]' - if(cnode_flags_set(cnode,cnode_args+2,proc_has_vkeys)) & - write(iunit,'(a)') ' [has vkeys]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_dcomm)) & - write(iunit,'(a)') ' [dcomm]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_file)) & - write(iunit,'(a)') ' [file]' - if(cnode_flags_set(cnode,cnode_args+2,proc_needs_par)) & - write(iunit,'(a)') ' [needs par]' - call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& - sig_cache,cnode_arg(cnode,1)) - write(iunit,'(a)') '}' - case(cnode_is_arglist) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'{' - if(cnode_flags_set(cnode,cnode_args+1,proc_is_var)) then - do i=5,cnode_numargs(cnode),2 - write(iunit,'(a)') trim(pm_name_as_string(context,& - cnode_get_name(cnode,cnode_args+i-1)))//' --> ['//& - trim(pm_int_as_string(cnode_get_num(cnode,cnode_args+i)))//']' - enddo - else - do i=3,cnode_numargs(cnode),2 - write(iunit,'(a)') ' '//& - trim(pm_name_as_string(context,& - key%data%i(key%offset+pm_fast_esize(key))))//& - trim(pm_type_as_string(context,& - cnode_num_arg(cnode,i)))//' {' - call print_proc_cnode(context,iunit,pm_null_obj,& - sig_cache,cnode_arg(cnode,i+1)) - write(iunit,'(a)') ' }' - enddo - endif - write(iunit,'(a)') '}' - case(cnode_is_any_sig) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Any{' - do i=1,cnode_numargs(cnode) - call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) - enddo - write(iunit,'(a)') '}' - case(cnode_is_autoconv_sig) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Auto {' - do i=1,cnode_numargs(cnode) - call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) - enddo - write(iunit,'(a)') '}' - end select - else - call pm_dump_tree(context,iunit,cnode,1) - endif - contains - include 'fesize.inc' - include 'fvkind.inc' - end subroutine print_sig - - subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - integer:: flags - if(cnode_get_kind(cnode)==cnode_is_builtin) then - write(iunit,'(a)') ' Builtin '//& - op_names(cnode_get_num(cnode,cnode_args))//& - pm_int_as_string(cnode_get_num(cnode,cnode_args+1))//'{' - if(.not.pm_fast_isnull(cnode_get(cnode,bi_rcode))) then - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,bi_rcode),4) - endif - write(iunit,'(a)') ' }' - else - write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & - ' [nargs=',& - cnode_get_num(cnode,pr_nargs),',nkeys=',& - cnode_get_num(cnode,pr_nkeys),',nret=',cnode_get_num(cnode,pr_nret),& - ',ncalls=',cnode_get_num(cnode,pr_ncalls),']' - if(cnode_flags_set(cnode,pr_flags,proc_is_comm)) & - write(iunit,'(a)') ' [loop]' - if(cnode_flags_set(cnode,pr_flags,proc_is_each_proc)) & - write(iunit,'(a)') ' [each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_dup_each)) & - write(iunit,'(a)') ' [dup-each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_thru_each)) & - write(iunit,'(a)') ' [thru-each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_empty_each)) & - write(iunit,'(a)') ' [empty-each]' - flags=cnode_get_kind(cnode) - !write(*,*) 'Kind=',flags - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_arg(cnode,1),4) - endif - contains - include 'fisnull.inc' - end subroutine print_proc_cnode - - subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) - type(pm_context),pointer:: context - integer,intent(in):: iunit,depth - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - type(pm_ptr)::p - p=cnode_get(cnode,cblock_first_call) - do while(.not.pm_fast_isnull(p)) - call print_call_cnode(context,iunit,rvec,sig_cache,p,depth) - p=cnode_get(p,call_link) - enddo - contains - include 'fisnull.inc' - end subroutine print_cblock_cnode - - subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) - type(pm_context),pointer:: context - integer,intent(in):: iunit,depth - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - integer:: signo,name,i,j,k,nret,nargs,modl,line - type(pm_ptr):: p,args,amps - character(len=120):: str,location - signo=cnode_get_num(cnode,call_sig) - if(signo<0) then - str=repeat(' ',depth)//pm_name_as_string(context,-signo) - i=len_trim(str)+1 - if(.not.pm_fast_isnull(rvec)) then - k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) - if(k>=0) then - call append_to_line(iunit,str,i,& - '['//trim(pm_int_as_string(k))//'] ',.false.,depth) - endif - endif - else - p=pm_dict_key(context,sig_cache,& - int(signo,pm_ln)) - name=p%data%i(p%offset+pm_fast_esize(p)) - if(.not.pm_fast_isnull(cnode_get(cnode,call_var))) then - str=repeat(' ',depth)//'call *(' - i=depth+7 - call print_value_cnode(context,iunit,rvec,sig_cache,& - cnode_get(cnode,call_var),depth,str,i) - call append_to_line(iunit,str,i,') ',.false.,depth) - elseif(pm_fast_isnull(rvec)) then - str=repeat(' ',depth)//'call '//pm_name_as_string(context,name) - else - k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) - if(k==spsig_thru) then - str=repeat(' ',depth)//'call [thru]'//& - pm_name_as_string(context,name) - elseif(k==spsig_dup) then - str=repeat(' ',depth)//'call [dup]'//& - pm_name_as_string(context,name) - elseif(k==spsig_noop) then - str=repeat(' ',depth)//'call [noop]'//& - pm_name_as_string(context,name) - elseif(k<0) then - str=repeat(' ',depth)//'call [??]'//& - pm_name_as_string(context,name) - else - str=repeat(' ',depth)//'call '//'['//trim(pm_int_as_string(k))//']'& - //pm_name_as_string(context,name) - endif - endif - i=len_trim(str) - call append_proc_call_flags(iunit,str,i,cnode_get_num(cnode,call_flags),.false.,depth) - i=i+1 - end if - - args=cnode_get(cnode,call_args) - nargs=cnode_numargs(args) - nret=cnode_get_num(cnode,call_nret) - amps=cnode_get(cnode,call_amp) - amps=pm_name_val(context,int(amps%offset)) - - if(nret>0) then - do j=1,nret - call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) - i=i+1 - enddo - call append_to_line(iunit,str,i,'<- ',.false.,depth) - endif - k=0 - do j=nret+1,nargs - if(.not.pm_fast_isnull(amps)) then - if(amps%data%i(amps%offset+k)==i-nret) then - call append_to_line(iunit,str,i,'&',.false.,depth) - k=min(k+1,pm_fast_esize(amps)) - endif - endif - call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) - i=i+1 - enddo - modl=cnode_get_num(cnode,cnode_modl_name) - line=cnode_get_num(cnode,cnode_lineno) - location=trim(pm_name_as_string(context,modl))//':'//pm_int_as_string(line) - str(len(str)-len_trim(location)+1:)=location - write(iunit,'(a)') str - - contains - include 'fesize.inc' - include 'fisnull.inc' - end subroutine print_call_cnode - - subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) - type(pm_context),pointer:: context - integer,intent(in):: iunit,depth - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - character(len=*),intent(inout):: str - integer,intent(inout):: i - integer:: kind,name,tno - kind=pm_fast_vkind(cnode) - if(kind==pm_tiny_int) then - call append_to_line(iunit,str,i,& - trim(pm_int_as_string(int(cnode%offset))),.false.,depth) - elseif(kind==pm_null) then - call append_to_line(iunit,str,i,& - 'NULL',.false.,depth) - elseif(kind==pm_name) then - call append_to_line(iunit,str,i,& - "'"//trim(pm_name_as_string(context,int(cnode%offset))),.false.,depth) - elseif(kind==pm_type) then - call append_to_line(iunit,str,i,& - '<'//trim(pm_type_as_string(context,int(cnode%offset)))//'>',.false.,depth) - else - kind=cnode_get_kind(cnode) - select case(kind) - case(cnode_is_var) - name=cnode_get_num(cnode,var_name) - if(name==0) then - call append_to_line(iunit,str,i,'#'//& - trim(pm_int_as_string(cnode_get_num(cnode,var_index))),.false.,depth) - else - call append_quoted_to_line(iunit,str,i,& - trim(pm_name_as_string(context,name)),.false.,depth) - endif - if(.not.pm_fast_isnull(rvec)) then - tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) - call append_to_line(iunit,str,i,& - '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) - endif - case(cnode_is_const) - call append_to_line(iunit,str,i,& - trim(pm_value_as_string(context,cnode_arg(cnode,1))),.false.,depth) - case(cnode_is_cblock) - call append_to_line(iunit,str,i,'{',.true.,depth) - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,min(50,depth+2)) - str=' ' - str(depth+1:depth+1)='}' - i=depth+1 - end select - endif - contains - include 'fvkind.inc' - include 'fisnull.inc' - end subroutine print_value_cnode - - subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) - integer,intent(in):: iunit - character(len=*),intent(inout):: str - integer,intent(inout):: i - integer,intent(in):: flags - logical,intent(in):: proc_flags - integer,intent(in):: depth - if(iand(flags,call_is_comm)/=0) then - call append_to_line(iunit,str,i,'%',.false.,depth) - endif - if(flags/=iand(flags,call_is_comm)) then - call append_to_line(iunit,str,i,'<',.false.,depth) - if(iand(flags,proc_run_complete)/=0) then - call append_to_line(iunit,str,i,'C',.false.,depth) - endif - if(iand(flags,proc_run_local)/=0) then - call append_to_line(iunit,str,i,'L',.false.,depth) - endif - if(iand(flags,proc_run_shared)/=0) then - call append_to_line(iunit,str,i,'S',.false.,depth) - endif - if(iand(flags,proc_run_always)/=0) then - call append_to_line(iunit,str,i,'A',.false.,depth) - endif - if(iand(flags,proc_inline)/=0) then - call append_to_line(iunit,str,i,'I',.false.,depth) - endif - if(iand(flags,proc_no_inline)/=0) then - call append_to_line(iunit,str,i,'N',.false.,depth) - endif - if(proc_flags) then - if(iand(flags,proc_is_open)/=0) then - call append_to_line(iunit,str,i,'o',.false.,depth) - endif - if(iand(flags,proc_is_each_proc)/=0) then - call append_to_line(iunit,str,i,'e',.false.,depth) - endif - if(iand(flags,proc_is_cond)/=0) then - call append_to_line(iunit,str,i,'c',.false.,depth) - endif - if(iand(flags,proc_is_uncond)/=0) then - call append_to_line(iunit,str,i,'u',.false.,depth) - endif - if(iand(flags,proc_is_abstract)/=0) then - call append_to_line(iunit,str,i,'a',.false.,depth) - endif - else - if(iand(flags,call_is_fixed)/=0) then - call append_to_line(iunit,str,i,'f',.false.,depth) - endif - if(iand(flags,call_is_assign_call)/=0) then - call append_to_line(iunit,str,i,'a',.false.,depth) - endif - if(iand(flags,call_is_vararg)/=0) then - call append_to_line(iunit,str,i,'v',.false.,depth) - endif - if(iand(flags,call_inline_when_compiling)/=0) then - call append_to_line(iunit,str,i,'i',.false.,depth) - endif - if(iand(flags,call_dup_result)/=0) then - call append_to_line(iunit,str,i,'d',.false.,depth) - endif - if(iand(flags,call_is_cond)/=0) then - call append_to_line(iunit,str,i,'c',.false.,depth) - endif - if(iand(flags,call_is_no_touch)/=0) then - call append_to_line(iunit,str,i,'n',.false.,depth) - endif - if(iand(flags,call_is_unlabelled)/=0) then - call append_to_line(iunit,str,i,'u',.false.,depth) - endif - endif - call append_to_line(iunit,str,i,'>',.false.,depth) - end if - end subroutine append_proc_call_flags - - subroutine append_quoted_to_line(iunit,str,i,part,break,depth) - integer,intent(in):: iunit - character(len=*),intent(inout):: str - integer,intent(inout):: i - character(len=*),intent(in):: part - logical,intent(in):: break - integer,intent(in):: depth - integer:: first - first=iachar(part(1:1)) - if(first>=iachar('a').and.first<=iachar('z').or.& - first>=iachar('A').and.first<=iachar('Z')) then - call append_to_line(iunit,str,i,part,break,depth) - else - call append_to_line(iunit,str,i,"'"//trim(part)//"'",break,depth) - endif - end subroutine append_quoted_to_line - - subroutine append_to_line(iunit,str,i,part,break,depth) - integer,intent(in):: iunit - character(len=*),intent(inout):: str - integer,intent(inout):: i - character(len=*),intent(in):: part - logical,intent(in):: break - integer,intent(in):: depth - integer:: n - n=len(part) - if(i+n>len(str)) then - write(iunit,'(a)') str(1:min(len(str),i)) - str=repeat(' ',depth+1)//part(1:min(len(str)-depth-1,n)) - i=depth+1+n - else - str(i+1:i+n)=part(1:n) - i=i+n - endif - if(break.or.i>len(str)) then - write(iunit,'(a)') str(1:i) - i=1 - endif - end subroutine append_to_line - - !======================================== ! Return the name of a given signature !======================================== @@ -9693,7 +9063,5 @@ subroutine cnode_error(coder,node,message,name,warn) end subroutine cnode_error - - end module pm_codegen diff --git a/src/deadcode.f90 b/src/deadcode.f90 new file mode 100644 index 0000000..07f3af6 --- /dev/null +++ b/src/deadcode.f90 @@ -0,0 +1,174 @@ +! +! PM (Parallel Models) Programming Language +! +! Released under the MIT License (MIT) +! +! Copyright (c) Tim Bellerby, 2024 +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. + +! Inter and intra-procedural dead code elimination + +module pm_deadcode + use pm_sysdep + use pm_compbase + use pm_kinds + use pm_memory + use pm_hash + use pm_lib + use pm_symbol + use pm_types + use pm_parser + use pm_sysdefs + use pm_cnodes + use pm_codegen + implicit none + + logical,parameter:: debug_deadcode=.false. + +contains + + recursive subroutine deadcode_proc(coder,proc) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: proc + + + ! Make sure everything called from here is analysed first + ! as we will need the parameter liveliness information + + + end subroutine deadcode_proc + + recursive subroutine find_procs_for_cblock(coder,cblock,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,rvec,procs + type(pm_ptr):: p + p=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + call find_procs_for_call(coder,p,rvec) + p=cblock_get(p,call_link) + end do + contains + include 'fisnull.inc' + end subroutine find_procs_for_cblock + + recursive subroutine find_procs_for_call(coder,callnode,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,rvec + integer:: sig,idx,i + type(pm_ptr):: procnode,args,arg + sig=cnode_get_num(callnode,call_sig) + if(sig>0) then + idx=cnode_get_num(callnode,call_index) + idx=rvec%data%i(rvec%offset+idx) + procnode=pm_dict_val(coder%context,coder%sig_cache,int(idx,pm_ln)) + if(pm_fast_isnull(cnode_arg(procnode,5))) then + call deadcode_proc(coder,procnode) + endif + else + args=cnode_get(callnode,call_args) + do i=1,cnode_numargs(args) + arg=cnode_arg(args,i) + if(pm_fast_vkind(arg)==pm_pointer) then + if(cnode_kind(arg)==cnode_is_cblock) then + call find_procs_for_cblock(coder,arg,rvec) + endif + endif + enddo + endif + end subroutine find_procs_for_call + + subroutine dce_cblock(coder,cblock,rvec,alive,nested,eliminate) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,rvec + logical,dimension(*):: alive + logical,intent(in):: nested,eliminate + type(pm_ptr):: p + p=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + call dce_call(coder,p,rvec,alive,eliminate) + p=cblock_get(p,call_link) + end do + contains + include 'fisnull.inc' + end subroutine dce_cblock + + subroutine dce_call(coder,callnode,rvec,alive,nested,eliminate) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,rvec + logical,dimension(*):: alive + logical,intent(in):: nested,eliminate + + args=cnode_get(callnode,call_args) + if(sig>0) then + + else + select case(-sig) + case(sym_if,sym_if_invar) + do while(.not.pm_fast_isnull(p)) + call vpush(coder,p) + enddo + case(sym_while) + + case(sym_until,sym_each) + if(.not.nested) then + + endif + + case default: + + outs_alive=.false. + do i=1,nret + arg=cnode_arg(args,i) + idx=cnode_get_num(arg,var_index) + outs_alive=outs_alive.or.alive(idx) + alive(idx)=.false. + enddo + has_blocks=.false. + do i=nret+1,cnode_numargs(args) + arg=cnode_arg(args,i) + if(pm_fast_vkind(arg)==pm_pointer) then + kind=cnode_kind(arg) + if(kind==cnode_is_var) then + idx=cnode_get_num(arg,var_index) + alive(idx)=.true. + elseif(kind==cnode_is_cblock) then + has_blocks=.true. + endif + endif + enddo + if(has_blocks) then + do i=1,cnode_numargs(args) + arg=cnode_arg(args,i) + if(pm_fast_vkind(arg)==pm_pointer) then + if(cnode_kind(arg)==cnode_is_cblock) then + call find_procs_for_cblock(coder,arg,rvec) + endif + endif + enddo + endif + end select + end if + if(eliminate.and.no_bad_taints.and..not.outs_alive) then + rev%data%i(rvec%offset+cnode_get_num(callnode,call_index))=& + call_noop_flag + endif + end subroutine dce_call + +end module pm_deadcode diff --git a/src/infer.f90 b/src/infer.f90 index 132f7ba..8b292c6 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -46,6 +46,7 @@ module pm_infer use pm_types use pm_parser use pm_sysdefs + use pm_cnodes use pm_codegen implicit none @@ -83,6 +84,18 @@ module pm_infer ! calls at compile time !============================================================= + subroutine arg_set_info(coder,arg) + type(code_state),intent(inout):: coder + end subroutine arg_set_info + + function arg_type(coder,arg) result(type) + type(code_state),intent(inout):: coder + end function arg_type + + function arg_type_and_mode(coder,arg,mode) result(type) + type(code_state),intent(inout):: coder + end function arg_type_and_mode + !============================== ! Type-infer main program !============================== diff --git a/src/lib.f90 b/src/lib.f90 index 7e8a2cf..ebac25e 100755 --- a/src/lib.f90 +++ b/src/lib.f90 @@ -279,6 +279,8 @@ function pm_value_as_string(context,v) result(str) str(i+3:i+3)='"' endif end do + case(pm_name) + str="'"//pm_name_as_string(context,int(v%offset)) case default str=pm_number_as_string(context,v,0_pm_ln) end select diff --git a/src/parser.f90 b/src/parser.f90 index a1c6513..a62b4ab 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -36,6 +36,7 @@ module pm_parser use pm_symbol use pm_vmdefs use pm_types + use pm_ast implicit none ! Print out lots of parser debugging info @@ -46,86 +47,6 @@ module pm_parser ! (this should not happen so is one test of gc) logical,parameter:: check_node_reuse=.false. - ! Offsets into module objects - integer,parameter:: modl_name=1 - integer,parameter:: modl_link=2 - integer,parameter:: modl_last=3 - integer,parameter:: modl_stmts=4 - integer,parameter:: modl_include=5 - integer,parameter:: modl_proc=6 - integer,parameter:: modl_type=7 - integer,parameter:: modl_param=8 - integer,parameter:: modl_local=3 - - ! Offsets into parser node objects of various kinds - integer,parameter:: node_magic=0 - integer,parameter:: node_symbol=1 - integer,parameter:: node_modl=2 - integer,parameter:: node_lineno=3 - integer,parameter:: node_charno=4 - integer,parameter:: node_args=5 - - ! Type parse nodes - integer,parameter:: typ_name=node_args - integer,parameter:: typ_number=node_args+1 - integer,parameter:: typ_module=node_args+2 - integer,parameter:: typ_params=node_args+3 - integer,parameter:: typ_constraints=node_args+4 - integer,parameter:: typ_link=node_args+5 - integer,parameter:: typ_ins=node_args+6 - integer,parameter:: typ_includes=node_args+7 - integer,parameter:: typ_num_args=8 - - ! Proc parse nodes - integer,parameter:: proc_name=node_args - integer,parameter:: proc_link=node_args+1 - integer,parameter:: proc_module=node_args+2 - integer,parameter:: proc_flags=node_args+3 - integer,parameter:: proc_params=node_args+4 - integer,parameter:: proc_keys=node_args+5 - integer,parameter:: proc_amplocs=node_args+6 - integer,parameter:: proc_coded_params=node_args+7 - integer,parameter:: proc_coded_results=node_args+8 - integer,parameter:: proc_coded_type=node_args+9 - integer,parameter:: proc_numret=node_args+10 - integer,parameter:: proc_result_types=node_args+11 - - ! Alternative final sections for 'proc' parse nodes - - ! - user functions - integer,parameter:: proc_reduce=node_args+12 - integer,parameter:: proc_check=node_args+13 - integer,parameter:: proc_result=node_args+14 - integer,parameter:: proc_stmts=node_args+15 - integer,parameter:: proc_code_tree=node_args+16 - integer,parameter:: proc_num_args=17 - - ! - built in functions - integer,parameter:: proc_retas=node_args+12 - integer,parameter:: proc_opcode=node_args+13 - integer,parameter:: proc_opcode2=node_args+14 - integer,parameter:: proc_data=node_args+15 - integer,parameter:: proc_coded_builtin=node_args+16 - integer,parameter:: sysproc_num_args=17 - - ! Values for flags (other values defined in sysdefs) - integer,parameter:: proc_is_comm=1 - integer,parameter:: proc_run_complete=2 - integer,parameter:: proc_run_local=4 - integer,parameter:: proc_run_shared=8 - integer,parameter:: proc_run_always=16 - integer,parameter:: proc_inline=32 - integer,parameter:: proc_no_inline=64 - integer,parameter:: proc_is_open=128 - integer,parameter:: proc_is_each_proc=256 - integer,parameter:: proc_is_cond=512 - integer,parameter:: proc_is_uncond=1024 - integer,parameter:: proc_is_abstract=2048 - - ! Corresponding flags in proc calls (must be same as for proc_is) - integer,parameter:: call_is_comm=1 - integer,parameter:: call_ignore_rules=256 - integer,parameter:: max_string=100 integer,parameter:: max_line=2001 integer,parameter:: max_parse_stack = 1024 @@ -6185,318 +6106,6 @@ function is_import(parser,name) result(ok) end function is_import - !====================================================== - ! Check that a node is valid - !====================================================== - subroutine check_node(node) - type(pm_ptr),intent(in):: node - if(pm_fast_vkind(node)==pm_pointer) then - if(node%data%ptr(node%offset)%offset/=9876) then - call pm_panic('Bad parse node') - endif - endif - contains - include 'fvkind.inc' - end subroutine check_node - - !======================================================= - ! Check that a node is valid and not a tiny int or value - !======================================================= - subroutine check_ptr_node(node) - type(pm_ptr),intent(in):: node - if(pm_fast_vkind(node)==pm_pointer) then - if(node%data%ptr(node%offset)%offset/=9876) then - call pm_panic('Bad parse node') - endif - else - call pm_panic('not ptr parser node') - endif - contains - include 'fvkind.inc' - end subroutine check_ptr_node - - !====================================================== - ! Return symbol associated with a node - !====================================================== - function node_sym(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_fast_vkind(node)/=pm_pointer) then - n=0 - else - if(pm_debug_checks) call check_node(node) - n=node%data%ptr(node%offset+node_symbol)%offset - endif - contains - include 'fvkind.inc' - end function node_sym - - !====================================================== - ! Number of arguments in a node - !====================================================== - function node_numargs(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_fast_vkind(node)/=pm_pointer) then - n=0 - else - if(pm_debug_checks) call check_node(node) - n=pm_fast_esize(node)-node_args+1 - endif - contains - include 'fesize.inc' - include 'fvkind.inc' - end function node_numargs - - !====================================================== - ! Return n-th argument of a node - !====================================================== - function node_arg(node,n) result(p) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.node_args+n-1>pm_fast_esize(node)) & - call pm_panic('node_arg - n out of range') - endif - p=node%data%ptr(node%offset+node_args+n-1) - contains - include 'fesize.inc' - end function node_arg - - !====================================================== - ! Return n-th argument of a node as a number - ! (that argument should be tiny-int) - !====================================================== - function node_num_arg(node,n) result(num) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - integer:: num - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.node_args+n-1>pm_fast_esize(node)) & - call pm_panic('node_arg - n out of range') - endif - p=node%data%ptr(node%offset+node_args+n-1) - num=p%offset - contains - include 'fesize.inc' - end function node_num_arg - - !====================================================== - ! Return n-th slot in a node (not the same as argument) - !====================================================== - function node_get(node,n) result(p) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.n>pm_fast_esize(node)) & - call pm_panic('node_get - n out of range') - endif - p=node%data%ptr(node%offset+n) - contains - include 'fesize.inc' - end function node_get - - !====================================================== - ! Return n-th slot in a node (not the same as argument) - ! as a number (must be tiny int) - !====================================================== - function node_get_num(node,n) result(num) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - integer:: num - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.n>pm_fast_esize(node)) & - call pm_panic('node_get_num - n out of range') - endif - p=node%data%ptr(node%offset+n) - num=p%offset - contains - include 'fesize.inc' - end function node_get_num - - !====================================================== - ! Set n-th slot in a node (not the same as argument) - ! to a number (tiny int) - !====================================================== - subroutine node_set_num(node,n,num) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - integer,intent(in):: num - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.n>pm_fast_esize(node)) & - call pm_panic('node_get_num - n out of range') - endif - node%data%ptr(node%offset+n)%offset=num - contains - include 'fesize.inc' - end subroutine node_set_num - - !====================================================== - ! Get the line number associated with a node - !====================================================== - function node_get_lineno(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_debug_checks) & - call check_ptr_node(node) - n=node%data%ptr(node%offset+node_lineno)%offset - end function node_get_lineno - - !====================================================== - ! Get the character position (in source) associated - ! with a node - !====================================================== - function node_get_charno(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_debug_checks) & - call check_ptr_node(node) - n=node%data%ptr(node%offset+node_charno)%offset - end function node_get_charno - - !====================================================== - ! Get the module object associated with a node - !====================================================== - function node_get_modl(node) result(modl) - type(pm_ptr),intent(in):: node - type(pm_ptr):: modl - if(pm_debug_checks) & - call check_ptr_node(node) - modl=node%data%ptr(node%offset+node_modl) - contains - include 'fvkind.inc' - end function node_get_modl - - !====================================================== - ! Get the module name associated with a node - !====================================================== - function node_get_modl_name(node) result(name) - type(pm_ptr),intent(in):: node - integer:: name - type(pm_ptr):: modl - if(pm_debug_checks) & - call check_ptr_node(node) - modl=node_get_modl(node) - name=modl%data%ptr(modl%offset+modl_name)%offset - end function node_get_modl_name - - - !====================================================== - ! Dump a module (debugging) - !====================================================== - subroutine dump_module(context,iunit,ptr) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: ptr - character(len=100):: str - character(len=7),dimension(modl_include:modl_param):: dnames = & - (/ & - 'include',& - 'proc ',& - 'type ',& - 'param '/) - integer:: i,j,k,m - type(pm_ptr):: keys,vals,p - call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) - write(iunit,*) 'Module: ',trim(str) - write(iunit,*) 'Stmts:' - call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+modl_stmts),2) - do k=0,modl_local,modl_local - if(k==modl_local) then - write(iunit,*) 'Local:' - m=modl_proc - else - ! m=modl_include - m=modl_proc - endif - do j=m,modl_param - write(iunit,*) dnames(j),& - marked(ptr%data%ptr(ptr%offset+j+k)),'::' - keys=pm_dict_keys(context,ptr%data%ptr(ptr%offset+j+k)) - vals=pm_dict_vals(context,ptr%data%ptr(ptr%offset+j+k)) - write(iunit,*) marked(keys),marked(vals) - do i=1,pm_dict_size(context,ptr%data%ptr(ptr%offset+j+k)) - call pm_name_string(context,& - int(keys%data%ptr(keys%offset+i-1)%offset),str) - write(iunit,*) ' ',trim(str),'::' - write(iunit,*) marked(vals%data%ptr(vals%offset+i-1)) - p=vals%data%ptr(vals%offset+i-1) - call dump_parse_tree(context,iunit,& - p%data%ptr(p%offset),2) - enddo - enddo - enddo - end subroutine dump_module - - !====================================================== - ! Dump a parser tree (debugging) - !====================================================== - recursive subroutine dump_parse_tree(context,iunit,ptr,depth) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: ptr - integer,intent(in):: depth - integer:: i, sym - character(len=80),parameter:: spaces = ' ' - character(len=100):: str - if(depth>30) then - write(iunit,*) spaces(:depth*2),'>>>' - return - endif - if(pm_fast_vkind(ptr)==pm_pointer) then - if(ptr%data%ptr(ptr%offset)%offset/=9876) then - if(ptr%data%ptr(ptr%offset)%offset==9875) then - write(iunit,*) spaces(1:depth*2),'REUSED NODE',& - ptr%offset,ptr%data%hash,ptr%data%esize - else - write(iunit,*) spaces(1:depth*2),'INVALID NODE' - return - endif - endif - sym=ptr%data%ptr(ptr%offset+1)%offset - if(sym>0.and.sym<=num_syshook) then - write(iunit,*) spaces(1:depth*2),sym_names(sym),ptr%data%esize,& - 'line',node_get_lineno(ptr),& - 'Marked:',marked(ptr),& - ptr%data%hash,ptr%offset,ptr%offset+ptr%data%esize - else if(sym==0) then - call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) - write(iunit,*) spaces(1:depth*2),'Module: ',trim(str) - return - else - write(iunit,*) spaces(1:depth*2),'???',trim(pm_name_as_string(context,sym)) - return - endif - do i=node_args,ptr%data%esize - call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+i),& - depth+1) - enddo - else if(pm_fast_isnull(ptr)) then - write(iunit,*) spaces(1:depth*2),'NULL' - else if(pm_fast_isname(ptr)) then - call pm_name_string(context,int(ptr%offset),str) - write(iunit,*) spaces(1:depth*2),'Name:',trim(str) - else if(pm_fast_istiny(ptr)) then - write(iunit,*) spaces(1:depth*2),'Tiny number:',ptr%offset - else - call pm_dump_tree(context,iunit,ptr,depth) - endif - contains - include 'fvkind.inc' - include 'fisnull.inc' - include 'fisname.inc' - include 'fistiny.inc' - end subroutine dump_parse_tree - !====================================================== ! Syntax error - print message ! and stop building parse tree diff --git a/src/sysdefs_old_nhd.f90 b/src/sysdefs_old_nhd.f90 deleted file mode 100755 index 6d0933b..0000000 --- a/src/sysdefs_old_nhd.f90 +++ /dev/null @@ -1,5597 +0,0 @@ -! -! PM (Parallel Models) Programming Language -! -! Released under the MIT License (MIT) -! -! Copyright (c) Tim Bellerby, 2023 -! -! Permission is hereby granted, free of charge, to any person obtaining a copy -! of this software and associated documentation files (the "Software"), to deal -! in the Software without restriction, including without limitation the rights -! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -! copies of the Software, and to permit persons to whom the Software is -! furnished to do so, subject to the following conditions: -! -! The above copyright notice and this permission notice shall be included in -! all copies or substantial portions of the Software. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -! THE SOFTWARE. - -! System module code (intrinsic types and procedures) -! Note: this is *not* written in canonical PM -! some rules are suspended and use is made of internal-only constructs - -module pm_sysdefs - use pm_kinds - use pm_memory - use pm_parser - use pm_hash - use pm_lib - use pm_symbol - use pm_types - use pm_vmdefs - implicit none - - ! Flag values for procs - ! (note values 1=proc_is_comm,... defined in parser) - integer,parameter:: proc_is_thru_each = 2**12 - integer,parameter:: proc_is_empty_each = 2**13 - integer,parameter:: proc_is_dup_each = 2**14 - integer,parameter:: proc_is_var = 2**15 - integer,parameter:: proc_is_generator = 2**16 - integer,parameter:: proc_needs_type = 2**17 - integer,parameter:: proc_is_recursive = 2**18 - integer,parameter:: proc_unfinished = 2**19 - integer,parameter:: proc_is_impure = 2**20 - integer,parameter:: proc_is_not_inlinable = 2**21 - integer,parameter:: proc_has_for = 2**22 - integer,parameter:: proc_is_not_pure_each = 2**23 - integer,parameter:: proc_has_vkeys = 2**24 - integer,parameter:: proc_is_dcomm = 2**25 - integer,parameter:: proc_is_variant = 2**26 - integer,parameter:: proc_needs_par = 2**27 - - integer,parameter:: proc_taints = proc_is_impure & - + proc_is_not_inlinable + proc_has_for & - + proc_is_not_pure_each + proc_is_variant & - + proc_needs_par - -contains - - subroutine sysdefs(parser) - type(parse_state):: parser - integer:: line - line=1 - - call dcl_module(parser,'PM__system') - parser%sysmodl=parser%modl - - ! ************************************** - ! BASIC TYPES - ! ************************************** - - ! String type - call dcl_proc(parser,'print(string)',op_print,0,line,proc_is_impure) - call dcl_uproc(parser,'print(x) { print(string(x)) }',line) - call dcl_proc(parser,'print_all(string)',op_print,1,line,proc_is_impure) - call dcl_uproc(parser,'print_all(x) { print_all(string(x)) }',line) - call dcl_proc(parser,'++(string,string)->string',op_concat,0,line,0) - call dcl_uproc(parser,'++(x:string,y)=$++.(x,string(y))',line) - call dcl_uproc(parser,'++(x,y)=$++.(string(x),string(y))',line) - call dcl_uproc(parser,'string(x:string)=x',line) - call dcl_uproc(parser,'string(x:null)="null"',line) - - ! sint type - call dcl_proc(parser,'PM__assign_var(&sint,sint)',& - op_assign_i,0,line,0) - call dcl_proc(parser,'mod(sint,sint)->sint',op_mod_i,0,line,0) - call dcl_proc(parser,'==(sint,sint)->bool',op_eq_i,0,line,0) - call dcl_proc(parser,'/=(sint,sint)->bool',op_ne_i,0,line,0) - call dcl_proc(parser,'>=(sint,sint)->bool',op_ge_i,0,line,0) - call dcl_proc(parser,'>(sint,sint)->bool',op_gt_i,0,line,0) - call dcl_proc(parser,'+(sint,sint)->sint',op_add_i,0,line,0) - call dcl_proc(parser,'-(sint,sint)->sint',op_sub_i,0,line,0) - call dcl_proc(parser,'*(sint,sint)->sint',op_mult_i,0,line,0) - call dcl_proc(parser,'/(sint,sint)->sint',op_divide_i,0,line,0) - call dcl_proc(parser,'**(sint,sint)->sint',op_pow_i,0,line,0) - call dcl_proc(parser,'max(sint,sint)->sint',op_max_i,0,line,0) - call dcl_proc(parser,'min(sint,sint)->sint',op_min_i,0,line,0) - call dcl_proc(parser,'-(sint)->sint',op_uminus_i,0,line,0) - call dcl_proc(parser,'string(sint)->string',op_string_i,0,line,0) - call dcl_proc(parser,'int(sint)->int',op_long_i,0,line,0) - call dcl_proc(parser,'sreal(sint)->sreal',op_real_i,0,line,0) - call dcl_proc(parser,'real(sint)->real',op_double_i,0,line,0) - call dcl_uproc(parser,'sint(x:sint)=x',line) - call dcl_proc(parser,'abs(sint)->sint',op_abs_i,0,line,0) - call dcl_proc(parser,'bit_not(sint)->sint',op_bnot_i,0,line,0) - call dcl_proc(parser,'&(sint,sint)->sint',op_band_i,0,line,0) - call dcl_proc(parser,'|(sint,sint)->sint',op_bor_i,0,line,0) - call dcl_proc(parser,'xor(sint,sint)->sint',op_bxor_i,0,line,0) - call dcl_proc(parser,'shift(sint,sint)->sint',op_bshift_i,0,line,0) - call dcl_proc(parser,'pdiff(sint,sint)->sint',op_pdiff_i,0,line,0) - call dcl_proc(parser,'sign(sint,sint)->sint',op_sign_i,0,line,0) - call dcl_proc(parser,'rem(sint,sint)->sint',op_modulo_i,0,line,0) - call dcl_proc(parser,'int8(sint)->int8',op_i8_i,0,line,0) - call dcl_proc(parser,'int16(sint)->int16',op_i16_i,0,line,0) - call dcl_proc(parser,'int32(sint)->int32',op_i32_i,0,line,0) - call dcl_proc(parser,'int64(sint)->int64',op_i64_i,0,line,0) - call dcl_proc(parser,'lint(sint)->lint',op_offset_i,0,line,0) - - ! int type - call dcl_proc(parser,'PM__assign_var(&int,int)',& - op_assign_ln,0,line,0) - call dcl_proc(parser,'mod(int,int)->''int',op_mod_ln,0,line,0) - call dcl_proc(parser,'==(int,int)->''bool',op_eq_ln,0,line,0) - call dcl_proc(parser,'/=(int,int)->''bool',op_ne_ln,0,line,0) - call dcl_proc(parser,'>=(int,int)->''bool',op_ge_ln,0,line,0) - call dcl_proc(parser,'>(int,int)->''bool',op_gt_ln,0,line,0) - call dcl_proc(parser,'+(int,int)->''int',op_add_ln,0,line,0) - call dcl_uproc(parser,'+(x:int,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int)=y',line) - call dcl_proc(parser,'-(int,int)->''int',op_sub_ln,0,line,0) - call dcl_uproc(parser,'-(x:int,y:''0)=x',line) - call dcl_proc(parser,'*(int,int)->''int',op_mult_ln,0,line,0) - call dcl_uproc(parser,'*(x:int,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int)=y',line) - call dcl_proc(parser,'/(int,int)->''int',op_divide_ln,0,line,0) - call dcl_uproc(parser,'/(x:int,y:''1)=x',line) - call dcl_proc(parser,'**(int,int)->''int',op_pow_ln,0,line,0) - call dcl_uproc(parser,'**(x:int,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) - call dcl_proc(parser,'max(int,int)->''int',op_max_ln,0,line,0) - call dcl_proc(parser,'min(int,int)->''int',op_min_ln,0,line,0) - call dcl_proc(parser,'-(int)->''int',op_uminus_ln,0,line,0) - call dcl_proc(parser,'string(int)->string',op_string_ln,0,line,0) - call dcl_proc(parser,'sint(int)->sint',op_int_ln,0,line,0) - call dcl_proc(parser,'sreal(int)->sreal',op_real_ln,0,line,0) - call dcl_proc(parser,'real(int)->real',op_double_ln,0,line,0) - call dcl_uproc(parser,'int(x:int)=x',line) - call dcl_proc(parser,'abs(int)->int',op_abs_ln,0,line,0) - call dcl_proc(parser,'!(int)->int',op_bnot_ln,0,line,0) - call dcl_proc(parser,'&(int,int)->int',op_band_ln,0,line,0) - call dcl_proc(parser,'|(int,int)->int',op_bor_ln,0,line,0) - call dcl_proc(parser,'xor(int,int)->int',op_bxor_ln,0,line,0) - call dcl_proc(parser,'shift(int,int)->int',& - op_bshift_ln,0,line,0) - call dcl_proc(parser,'pdiff(int,int)->''int',op_pdiff_ln,0,line,0) - call dcl_proc(parser,'sign(int,int)->''int',op_sign_ln,0,line,0) - call dcl_proc(parser,'rem(int,int)->''int',op_modulo_ln,0,line,0) - call dcl_proc(parser,'int8(int)->int8',op_i8_ln,0,line,0) - call dcl_proc(parser,'int16(int)->int16',op_i16_ln,0,line,0) - call dcl_proc(parser,'int32(int)->int32',op_i32_ln,0,line,0) - call dcl_proc(parser,'int64(int)->int64',op_i64_ln,0,line,0) - call dcl_proc(parser,'lint(int)->lint',op_offset_ln,0,line,0) - - ! lint type - call dcl_proc(parser,'PM__assign_var(&lint,lint)',& - op_assign_offset,0,line,0) - call dcl_proc(parser,'mod(lint,lint)->lint',op_mod_offset,0,line,0) - call dcl_proc(parser,'==(lint,lint)->bool',op_eq_offset,0,line,0) - call dcl_proc(parser,'/=(lint,lint)->bool',op_ne_offset,0,line,0) - call dcl_proc(parser,'>=(lint,lint)->bool',op_ge_offset,0,line,0) - call dcl_proc(parser,'>(lint,lint)->bool',op_gt_offset,0,line,0) - call dcl_proc(parser,'+(lint,lint)->lint',op_add_offset,0,line,0) - call dcl_uproc(parser,'+(x:lint,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:lint)=y',line) - call dcl_proc(parser,'-(lint,lint)->lint',op_sub_offset,0,line,0) - call dcl_uproc(parser,'-(x:lint,y:''0)=x',line) - call dcl_proc(parser,'*(lint,lint)->lint',op_mult_offset,0,line,0) - call dcl_uproc(parser,'*(x:lint,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:lint)=y',line) - call dcl_proc(parser,'/(lint,lint)->lint',op_divide_offset,0,line,0) - call dcl_uproc(parser,'/(x:lint,y:''1)=x',line) - call dcl_proc(parser,'**(lint,lint)->lint',op_pow_offset,0,line,0) - call dcl_uproc(parser,'**(x:lint,y:''0)=1',line) - call dcl_uproc(parser,'**(x:lint,y:''1)=x',line) - call dcl_uproc(parser,'**(x:lint,y:''2)=x*x',line) - call dcl_proc(parser,'max(lint,lint)->lint',op_max_offset,0,line,0) - call dcl_proc(parser,'min(lint,lint)->lint',op_min_offset,0,line,0) - call dcl_proc(parser,'-(lint)->lint',op_uminus_offset,0,line,0) - call dcl_proc(parser,'string(lint)->string',op_string_offset,0,line,0) - call dcl_proc(parser,'sint(lint)->sint',op_int_offset,0,line,0) - call dcl_proc(parser,'sreal(lint)->sreal',op_real_offset,0,line,0) - call dcl_proc(parser,'real(lint)->real',op_double_offset,0,line,0) - call dcl_uproc(parser,'lint(x:lint)=x',line) - call dcl_proc(parser,'abs(lint)->lint',op_abs_offset,0,line,0) - call dcl_proc(parser,'!(lint)->lint',op_bnot_offset,0,line,0) - call dcl_proc(parser,'&(lint,lint)->lint',op_band_offset,0,line,0) - call dcl_proc(parser,'|(lint,lint)->lint',op_bor_offset,0,line,0) - call dcl_proc(parser,'xor(lint,lint)->lint',op_bxor_offset,0,line,0) - call dcl_proc(parser,'shift(lint,lint)->lint',& - op_bshift_offset,0,line,0) - call dcl_proc(parser,'pdiff(lint,lint)->lint',op_pdiff_offset,0,line,0) - call dcl_proc(parser,'sign(lint,lint)->lint',op_sign_offset,0,line,0) - call dcl_proc(parser,'rem(lint,lint)->lint',op_modulo_offset,0,line,0) - call dcl_proc(parser,'int8(lint)->int8',op_i8_offset,0,line,0) - call dcl_proc(parser,'int16(lint)->int16',op_i16_offset,0,line,0) - call dcl_proc(parser,'int32(lint)->int32',op_i32_offset,0,line,0) - call dcl_proc(parser,'int64(lint)->int64',op_i64_offset,0,line,0) - call dcl_proc(parser,'int(lint)->int',op_long_offset,0,line,0) - - ! int8 type - call dcl_proc(parser,'PM__assign_var(&int8,int8)',& - op_assign_i8,0,line,0) - call dcl_proc(parser,'mod(int8,int8)->int8',op_mod_i8,0,line,0) - call dcl_proc(parser,'==(int8,int8)->bool',op_eq_i8,0,line,0) - call dcl_proc(parser,'/=(int8,int8)->bool',op_ne_i8,0,line,0) - call dcl_proc(parser,'>=(int8,int8)->bool',op_ge_i8,0,line,0) - call dcl_proc(parser,'>(int8,int8)->bool',op_gt_i8,0,line,0) - call dcl_proc(parser,'+(int8,int8)->int8',op_add_i8,0,line,0) - call dcl_uproc(parser,'+(x:int8,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int8)=y',line) - call dcl_proc(parser,'-(int8,int8)->int8',op_sub_i8,0,line,0) - call dcl_uproc(parser,'-(x:int8,y:''0)=x',line) - call dcl_proc(parser,'*(int8,int8)->int8',op_mult_i8,0,line,0) - call dcl_uproc(parser,'*(x:int8,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int8)=y',line) - call dcl_proc(parser,'/(int8,int8)->int8',op_divide_i8,0,line,0) - call dcl_uproc(parser,'/(x:int8,y:''1)=x',line) - call dcl_proc(parser,'**(int8,int8)->int8',op_pow_i8,0,line,0) - call dcl_uproc(parser,'**(x:int8,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int8,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int8,y:''2)=x*x',line) - call dcl_proc(parser,'max(int8,int8)->int8',op_max_i8,0,line,0) - call dcl_proc(parser,'min(int8,int8)->int8',op_min_i8,0,line,0) - call dcl_proc(parser,'-(int8)->int8',op_uminus_i8,0,line,0) - call dcl_proc(parser,'sint(int8)->sint',op_int_i8,0,line,0) - call dcl_proc(parser,'sreal(int8)->sreal',op_real_i8,0,line,0) - call dcl_proc(parser,'real(int8)->real',op_double_i8,0,line,0) - call dcl_uproc(parser,'int8(x:int8)=x',line) - call dcl_proc(parser,'abs(int8)->int8',op_abs_i8,0,line,0) - call dcl_proc(parser,'!(int8)->int8',op_bnot_i8,0,line,0) - call dcl_proc(parser,'&(int8,int8)->int8',op_band_i8,0,line,0) - call dcl_proc(parser,'|(int8,int8)->int8',op_bor_i8,0,line,0) - call dcl_proc(parser,'xor(int8,int8)->int8',op_bxor_i8,0,line,0) - call dcl_proc(parser,'shift(int8,int8)->int8',& - op_bshift_i8,0,line,0) - call dcl_proc(parser,'pdiff(int8,int8)->int8',op_pdiff_i8,0,line,0) - call dcl_proc(parser,'sign(int8,int8)->int8',op_sign_i8,0,line,0) - call dcl_proc(parser,'rem(int8,int8)->int8',op_modulo_i8,0,line,0) - call dcl_proc(parser,'int16(int8)->int16',op_i16_i8,0,line,0) - call dcl_proc(parser,'int32(int8)->int32',op_i32_i8,0,line,0) - call dcl_proc(parser,'int64(int8)->int64',op_i64_i8,0,line,0) - call dcl_proc(parser,'int(int8)->int',op_long_i8,0,line,0) - call dcl_proc(parser,'lint(int8)->lint',op_offset_i8,0,line,0) - - ! int16 type - call dcl_proc(parser,'PM__assign_var(&int16,int16)',& - op_assign_i16,0,line,0) - call dcl_proc(parser,'mod(int16,int16)->int16',op_mod_i16,0,line,0) - call dcl_proc(parser,'==(int16,int16)->bool',op_eq_i16,0,line,0) - call dcl_proc(parser,'/=(int16,int16)->bool',op_ne_i16,0,line,0) - call dcl_proc(parser,'>=(int16,int16)->bool',op_ge_i16,0,line,0) - call dcl_proc(parser,'>(int16,int16)->bool',op_gt_i16,0,line,0) - call dcl_proc(parser,'+(int16,int16)->int16',op_add_i16,0,line,0) - call dcl_uproc(parser,'+(x:int16,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int16)=y',line) - call dcl_proc(parser,'-(int16,int16)->int16',op_sub_i16,0,line,0) - call dcl_uproc(parser,'-(x:int16,y:''0)=x',line) - call dcl_proc(parser,'*(int16,int16)->int16',op_mult_i16,0,line,0) - call dcl_uproc(parser,'*(x:int16,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int16)=y',line) - call dcl_proc(parser,'/(int16,int16)->int16',op_divide_i16,0,line,0) - call dcl_uproc(parser,'/(x:int16,y:''1)=x',line) - call dcl_proc(parser,'**(int16,int16)->int16',op_pow_i16,0,line,0) - call dcl_uproc(parser,'**(x:int16,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int16,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int16,y:''2)=x*x',line) - call dcl_proc(parser,'max(int16,int16)->int16',op_max_i16,0,line,0) - call dcl_proc(parser,'min(int16,int16)->int16',op_min_i16,0,line,0) - call dcl_proc(parser,'-(int16)->int16',op_uminus_i16,0,line,0) - call dcl_proc(parser,'sint(int16)->sint',op_int_i16,0,line,0) - call dcl_proc(parser,'sreal(int16)->sreal',op_real_i16,0,line,0) - call dcl_proc(parser,'real(int16)->real',op_double_i16,0,line,0) - call dcl_uproc(parser,'int16(x:int16)=x',line) - call dcl_proc(parser,'abs(int16)->int16',op_abs_i16,0,line,0) - call dcl_proc(parser,'!(int16)->int16',op_bnot_i16,0,line,0) - call dcl_proc(parser,'&(int16,int16)->int16',op_band_i16,0,line,0) - call dcl_proc(parser,'|(int16,int16)->int16',op_bor_i16,0,line,0) - call dcl_proc(parser,'xor(int16,int16)->int16',op_bxor_i16,0,line,0) - call dcl_proc(parser,'shift(int16,int16)->int16',& - op_bshift_i16,0,line,0) - call dcl_proc(parser,'pdiff(int16,int16)->int16',op_pdiff_i16,0,line,0) - call dcl_proc(parser,'sign(int16,int16)->int16',op_sign_i16,0,line,0) - call dcl_proc(parser,'rem(int16,int16)->int16',op_modulo_i16,0,line,0) - call dcl_proc(parser,'int8(int16)->int16',op_i8_i16,0,line,0) - call dcl_proc(parser,'int32(int16)->int32',op_i32_i16,0,line,0) - call dcl_proc(parser,'int64(int16)->int64',op_i64_i16,0,line,0) - call dcl_proc(parser,'int(int16)->int',op_long_i16,0,line,0) - call dcl_proc(parser,'lint(int16)->lint',op_offset_i16,0,line,0) - - ! int32 type - call dcl_proc(parser,'PM__assign_var(&int32,int32)',& - op_assign_i32,0,line,0) - call dcl_proc(parser,'mod(int32,int32)->int32',op_mod_i32,0,line,0) - call dcl_proc(parser,'==(int32,int32)->bool',op_eq_i32,0,line,0) - call dcl_proc(parser,'/=(int32,int32)->bool',op_ne_i32,0,line,0) - call dcl_proc(parser,'>=(int32,int32)->bool',op_ge_i32,0,line,0) - call dcl_proc(parser,'>(int32,int32)->bool',op_gt_i32,0,line,0) - call dcl_proc(parser,'+(int32,int32)->int32',op_add_i32,0,line,0) - call dcl_uproc(parser,'+(x:int32,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int32)=y',line) - call dcl_proc(parser,'-(int32,int32)->int32',op_sub_i32,0,line,0) - call dcl_uproc(parser,'-(x:int32,y:''0)=x',line) - call dcl_proc(parser,'*(int32,int32)->int32',op_mult_i32,0,line,0) - call dcl_uproc(parser,'*(x:int32,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int32)=y',line) - call dcl_proc(parser,'/(int32,int32)->int32',op_divide_i32,0,line,0) - call dcl_uproc(parser,'/(x:int32,y:''1)=x',line) - call dcl_proc(parser,'**(int32,int32)->int32',op_pow_i32,0,line,0) - call dcl_uproc(parser,'**(x:int32,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int32,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int32,y:''2)=x*x',line) - call dcl_proc(parser,'max(int32,int32)->int32',op_max_i32,0,line,0) - call dcl_proc(parser,'min(int32,int32)->int32',op_min_i32,0,line,0) - call dcl_proc(parser,'-(int32)->int32',op_uminus_i32,0,line,0) - call dcl_proc(parser,'sint(int32)->sint',op_int_i32,0,line,0) - call dcl_proc(parser,'sreal(int32)->sreal',op_real_i32,0,line,0) - call dcl_proc(parser,'real(int32)->real',op_double_i32,0,line,0) - call dcl_uproc(parser,'int32(x:int32)=x',line) - call dcl_proc(parser,'abs(int32)->int32',op_abs_i32,0,line,0) - call dcl_proc(parser,'!(int32)->int32',op_bnot_i32,0,line,0) - call dcl_proc(parser,'&(int32,int32)->int32',op_band_i32,0,line,0) - call dcl_proc(parser,'|(int32,int32)->int32',op_bor_i32,0,line,0) - call dcl_proc(parser,'xor(int32,int32)->int32',op_bxor_i32,0,line,0) - call dcl_proc(parser,'shift(int32,int32)->int32',& - op_bshift_i32,0,line,0) - call dcl_proc(parser,'pdiff(int32,int32)->int32',op_pdiff_i32,0,line,0) - call dcl_proc(parser,'sign(int32,int32)->int32',op_sign_i32,0,line,0) - call dcl_proc(parser,'rem(int32,int32)->int32',op_modulo_i32,0,line,0) - call dcl_proc(parser,'int8(int32)->int32',op_i8_i32,0,line,0) - call dcl_proc(parser,'int16(int32)->int32',op_i16_i32,0,line,0) - call dcl_proc(parser,'int64(int32)->int64',op_i64_i32,0,line,0) - call dcl_proc(parser,'int(int32)->int',op_long_i32,0,line,0) - call dcl_proc(parser,'lint(int32)->lint',op_offset_i32,0,line,0) - - ! int64 type - call dcl_proc(parser,'PM__assign_var(&int64,int64)',& - op_assign_i64,0,line,0) - call dcl_proc(parser,'mod(int64,int64)->int64',op_mod_i64,0,line,0) - call dcl_proc(parser,'==(int64,int64)->bool',op_eq_i64,0,line,0) - call dcl_proc(parser,'/=(int64,int64)->bool',op_ne_i64,0,line,0) - call dcl_proc(parser,'>=(int64,int64)->bool',op_ge_i64,0,line,0) - call dcl_proc(parser,'>(int64,int64)->bool',op_gt_i64,0,line,0) - call dcl_proc(parser,'+(int64,int64)->int64',op_add_i64,0,line,0) - call dcl_uproc(parser,'+(x:int64,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int64)=y',line) - call dcl_proc(parser,'-(int64,int64)->int64',op_sub_i64,0,line,0) - call dcl_uproc(parser,'-(x:int64,y:''0)=x',line) - call dcl_proc(parser,'*(int64,int64)->int64',op_mult_i64,0,line,0) - call dcl_uproc(parser,'*(x:int64,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int64)=y',line) - call dcl_proc(parser,'/(int64,int64)->int64',op_divide_i64,0,line,0) - call dcl_uproc(parser,'/(x:int64,y:''1)=x',line) - call dcl_proc(parser,'**(int64,int64)->int64',op_pow_i64,0,line,0) - call dcl_uproc(parser,'**(x:int64,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int64,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int64,y:''2)=x*x',line) - call dcl_proc(parser,'max(int64,int64)->int64',op_max_i64,0,line,0) - call dcl_proc(parser,'min(int64,int64)->int64',op_min_i64,0,line,0) - call dcl_proc(parser,'-(int64)->int64',op_uminus_i64,0,line,0) - call dcl_proc(parser,'string(int64)->string',op_string_i64,0,line,0) - call dcl_proc(parser,'sint(int64)->sint',op_int_i64,0,line,0) - call dcl_proc(parser,'sreal(int64)->sreal',op_real_i64,0,line,0) - call dcl_proc(parser,'real(int64)->real',op_double_i64,0,line,0) - call dcl_uproc(parser,'int64(x:int64)=x',line) - call dcl_proc(parser,'abs(int64)->int64',op_abs_i64,0,line,0) - call dcl_proc(parser,'!(int64)->int64',op_bnot_i64,0,line,0) - call dcl_proc(parser,'&(int64,int64)->int64',op_band_i64,0,line,0) - call dcl_proc(parser,'|(int64,int64)->int64',op_bor_i64,0,line,0) - call dcl_proc(parser,'xor(int64,int64)->int64',op_bxor_i64,0,line,0) - call dcl_proc(parser,'shift(int64,int64)->int64',& - op_bshift_i64,0,line,0) - call dcl_proc(parser,'pdiff(int64,int64)->int64',op_pdiff_i64,0,line,0) - call dcl_proc(parser,'sign(int64,int64)->int64',op_sign_i64,0,line,0) - call dcl_proc(parser,'rem(int64,int64)->int64',op_modulo_i64,0,line,0) - call dcl_proc(parser,'int8(int64)->int64',op_i8_i64,0,line,0) - call dcl_proc(parser,'int16(int64)->int64',op_i16_i64,0,line,0) - call dcl_proc(parser,'int32(int64)->int64',op_i32_i64,0,line,0) - call dcl_proc(parser,'int(int64)->int',op_long_i64,0,line,0) - call dcl_proc(parser,'lint(int64)->lint',op_offset_i64,0,line,0) - - ! sreal type - call dcl_proc(parser,'PM__assign_var(&sreal,sreal)',& - op_assign_r,0,line,0) - call dcl_proc(parser,'mod(sreal,sreal)->sreal',op_mod_r,0,line,0) - call dcl_proc(parser,'==(sreal,sreal)->bool',op_eq_r,0,line,0) - call dcl_proc(parser,'/=(sreal,sreal)->bool',op_ne_r,0,line,0) - call dcl_proc(parser,'>=(sreal,sreal)->bool',op_ge_r,0,line,0) - call dcl_proc(parser,'>(sreal,sreal)->bool',op_gt_r,0,line,0) - call dcl_proc(parser,'+(sreal,sreal)->sreal',op_add_r,0,line,0) - call dcl_proc(parser,'-(sreal,sreal)->sreal',op_sub_r,0,line,0) - call dcl_proc(parser,'*(sreal,sreal)->sreal',op_mult_r,0,line,0) - call dcl_proc(parser,'/(sreal,sreal)->sreal',op_divide_r,0,line,0) - call dcl_proc(parser,'**(sreal,sreal)->sreal',op_pow_r,0,line,0) - call dcl_proc(parser,'max(sreal,sreal)->sreal',op_max_r,0,line,0) - call dcl_proc(parser,'min(sreal,sreal)->sreal',op_min_r,0,line,0) - call dcl_proc(parser,'-(sreal)->sreal',op_uminus_r,0,line,0) - call dcl_proc(parser,'string(sreal)->string',op_string_r,0,line,0) - call dcl_proc(parser,'strunc(sreal)->sint',op_int_r,0,line,0) - call dcl_proc(parser,'trunc(sreal)->int',op_long_r,0,line,0) - call dcl_proc(parser,'ltrunc(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'real(sreal)->real',op_double_r,0,line,0) - call dcl_uproc(parser,'sreal(x:sreal)=x',line) - call dcl_proc(parser,'abs(sreal)->sreal',op_abs_r,0,line,0) - call dcl_proc(parser,'acos(sreal)->sreal',op_acos_r,0,line,0) - call dcl_proc(parser,'asin(sreal)->sreal',op_asin_r,0,line,0) - call dcl_proc(parser,'atan(sreal)->sreal',op_atan_r,0,line,0) - call dcl_proc(parser,'atan2(sreal,sreal)->sreal',op_atan2_r,0,line,0) - call dcl_proc(parser,'cos(sreal)->sreal',op_cos_r,0,line,0) - call dcl_proc(parser,'cosh(sreal)->sreal',op_cosh_r,0,line,0) - call dcl_proc(parser,'exp(sreal)->sreal',op_exp_r,0,line,0) - call dcl_proc(parser,'log(sreal)->sreal',op_log_r,0,line,0) - call dcl_proc(parser,'log10(sreal)->sreal',op_log10_r,0,line,0) - call dcl_proc(parser,'sin(sreal)->sreal',op_sin_r,0,line,0) - call dcl_proc(parser,'sinh(sreal)->sreal',op_sinh_r,0,line,0) - call dcl_proc(parser,'sqrt(sreal)->sreal',op_sqrt_r,0,line,0) - call dcl_proc(parser,'tan(sreal)->sreal',op_tan_r,0,line,0) - call dcl_proc(parser,'tanh(sreal)->sreal',op_tanh_r,0,line,0) - call dcl_proc(parser,'floor(sreal)->sreal',op_floor_r,0,line,0) - call dcl_proc(parser,'ceil(sreal)->sreal',op_ceil_r,0,line,0) - call dcl_proc(parser,'rem(sreal,sreal)->sreal',op_modulo_r,0,line,0) - call dcl_proc(parser,'sign(sreal,sreal)->sreal',op_sign_r,0,line,0) - call dcl_proc(parser,'pdiff(sreal,sreal)->sreal',op_pdiff_r,0,line,0) - call dcl_proc(parser,'lint(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'scpx(sreal)->scpx',op_complex_r,0,line,0) - call dcl_proc(parser,'_scpx2(sreal,sreal)->scpx',op_complex2_r,0,line,0) - call dcl_uproc(parser,'scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y))',line) - - ! real type - call dcl_proc(parser,'PM__assign_var(&real,real)',& - op_assign_d,0,line,0) - call dcl_proc(parser,'mod(real,real)->real',op_mod_d,0,line,0) - call dcl_proc(parser,'==(real,real)->bool',op_eq_d,0,line,0) - call dcl_proc(parser,'/=(real,real)->bool',op_ne_d,0,line,0) - call dcl_proc(parser,'>=(real,real)->bool',op_ge_d,0,line,0) - call dcl_proc(parser,'>(real,real)->bool',op_gt_d,0,line,0) - call dcl_proc(parser,'+(real,real)->real',op_add_d,0,line,0) - call dcl_proc(parser,'-(real,real)->real',op_sub_d,0,line,0) - call dcl_proc(parser,'*(real,real)->real',op_mult_d,0,line,0) - call dcl_proc(parser,'/(real,real)->real',op_divide_d,0,line,0) - call dcl_proc(parser,'**(real,real)->real',op_pow_d,0,line,0) - call dcl_proc(parser,'max(real,real)->real',op_max_d,0,line,0) - call dcl_proc(parser,'min(real,real)->real',op_min_d,0,line,0) - call dcl_proc(parser,'-(real)->real',op_uminus_d,0,line,0) - call dcl_proc(parser,'string(real)->string',op_string_d,0,line,0) - call dcl_proc(parser,'strunc(real)->sint',op_int_d,0,line,0) - call dcl_proc(parser,'trunc(real)->int',op_long_d,0,line,0) - call dcl_proc(parser,'ltrunc(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'sreal(real)->sreal',op_real_d,0,line,0) - call dcl_uproc(parser,'real(x:real)=x',line) - call dcl_proc(parser,'abs(real)->real',op_abs_d,0,line,0) - call dcl_proc(parser,'acos(real)->real',op_acos_d,0,line,0) - call dcl_proc(parser,'asin(real)->real',op_asin_d,0,line,0) - call dcl_proc(parser,'atan(real)->real',op_atan_d,0,line,0) - call dcl_proc(parser,'atan2(real,real)->real',& - op_atan2_d,0,line,0) - call dcl_proc(parser,'cos(real)->real',op_cos_d,0,line,0) - call dcl_proc(parser,'cosh(real)->real',op_cosh_d,0,line,0) - call dcl_proc(parser,'exp(real)->real',op_exp_d,0,line,0) - call dcl_proc(parser,'log(real)->real',op_log_d,0,line,0) - call dcl_proc(parser,'log10(real)->real',op_log10_d,0,line,0) - call dcl_proc(parser,'sin(real)->real',op_sin_d,0,line,0) - call dcl_proc(parser,'sinh(real)->real',op_sinh_d,0,line,0) - call dcl_proc(parser,'sqrt(real)->real',op_sqrt_d,0,line,0) - call dcl_proc(parser,'tan(real)->real',op_tan_d,0,line,0) - call dcl_proc(parser,'tanh(real)->real',op_tanh_d,0,line,0) - call dcl_proc(parser,'floor(real)->real',op_floor_d,0,line,0) - call dcl_proc(parser,'ceil(real)->real',op_ceil_d,0,line,0) - call dcl_proc(parser,'rem(real,real)->real',op_modulo_d,0,line,0) - call dcl_proc(parser,'sign(real,real)->real',op_sign_d,0,line,0) - call dcl_proc(parser,'pdiff(real,real)->real',op_pdiff_d,0,line,0) - call dcl_proc(parser,'lint(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'cpx(real)->cpx',op_complex_d,0,line,0) - call dcl_proc(parser,'_cpx2(real,real)->cpx',op_complex2_d,0,line,0) - call dcl_uproc(parser,'cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y))',line) - - ! scpx type - call dcl_proc(parser,'PM__assign_var(&scpx,scpx)',& - op_assign_c,0,line,0) - call dcl_proc(parser,'+(scpx,scpx)->scpx',op_add_c,0,line,0) - call dcl_proc(parser,'-(scpx,scpx)->scpx',op_sub_c,0,line,0) - call dcl_proc(parser,'*(scpx,scpx)->scpx',op_mult_c,0,line,0) - call dcl_proc(parser,'/(scpx,scpx)->scpx',op_divide_c,0,line,0) - call dcl_proc(parser,'**(scpx,sreal)->scpx',op_rpow_c,0,line,0) - call dcl_proc(parser,'**(scpx,scpx)->scpx',op_pow_c,0,line,0) - call dcl_proc(parser,'-(scpx)->scpx',op_uminus_c,0,line,0) - call dcl_proc(parser,'==(scpx,scpx)->bool',op_eq_c,0,line,0) - call dcl_proc(parser,'/=(scpx,scpx)->bool',op_ne_c,0,line,0) - call dcl_proc(parser,'re(scpx)->sreal',op_real_c,0,line,0) - call dcl_proc(parser,'abs(scpx)->scpx',op_abs_c,0,line,0) - call dcl_proc(parser,'acos(scpx)->scpx',op_acos_c,0,line,0) - call dcl_proc(parser,'asin(scpx)->scpx',op_asin_c,0,line,0) - call dcl_proc(parser,'atan(scpx)->scpx',op_atan_c,0,line,0) - call dcl_proc(parser,'atan2(scpx,scpx)->scpx',& - op_atan2_c,0,line,0) - call dcl_proc(parser,'cos(scpx)->scpx',op_cos_c,0,line,0) - call dcl_proc(parser,'cosh(scpx)->scpx',op_cosh_c,0,line,0) - call dcl_proc(parser,'exp(scpx)->scpx',op_exp_c,0,line,0) - call dcl_proc(parser,'log(scpx)->scpx',op_log_c,0,line,0) - call dcl_proc(parser,'sin(scpx)->scpx',op_sin_c,0,line,0) - call dcl_proc(parser,'sinh(scpx)->scpx',op_sinh_c,0,line,0) - call dcl_proc(parser,'sqrt(scpx)->scpx',op_sqrt_c,0,line,0) - call dcl_proc(parser,'tan(scpx)->scpx',op_tan_c,0,line,0) - call dcl_proc(parser,'tanh(scpx)->scpx',op_tanh_c,0,line,0) - call dcl_proc(parser,'im(scpx)->sreal',op_imag_c,0,line,0) - call dcl_proc(parser,'conj(scpx)->scpx',op_conj_c,0,line,0) - - ! cpx type - call dcl_proc(parser,'PM__assign_var(&cpx,cpx)',& - op_assign_dc,0,line,0) - call dcl_proc(parser,'+(cpx,cpx)->cpx',op_add_dc,0,line,0) - call dcl_proc(parser,'-(cpx,cpx)->cpx',op_sub_dc,0,line,0) - call dcl_proc(parser,'*(cpx,cpx)->cpx',op_mult_dc,0,line,0) - call dcl_proc(parser,'/(cpx,cpx)->cpx',op_divide_dc,0,line,0) - call dcl_proc(parser,'**(cpx,real)->cpx',op_dpow_dc,0,line,0) - call dcl_uproc(parser,'**(x:cpx,y:sreal)=x**real(y)',line) - call dcl_proc(parser,'**(cpx,cpx)->cpx',op_pow_dc,0,line,0) - call dcl_proc(parser,'-(cpx)->cpx',op_uminus_dc,0,line,0) - call dcl_proc(parser,'==(cpx,cpx)->bool',op_eq_dc,0,line,0) - call dcl_proc(parser,'/=(cpx,cpx)->bool',op_ne_dc,0,line,0) - call dcl_proc(parser,'re(cpx)->real',op_real_dc,0,line,0) - call dcl_proc(parser,'abs(cpx)->cpx',op_abs_dc,0,line,0) - call dcl_proc(parser,'acos(cpx)->cpx',op_acos_dc,0,line,0) - call dcl_proc(parser,'asin(cpx)->cpx',op_asin_dc,0,line,0) - call dcl_proc(parser,'atan(cpx)->cpx',op_atan_dc,0,line,0) - call dcl_proc(parser,'atan2(cpx,cpx)->cpx',& - op_atan2_dc,0,line,0) - call dcl_proc(parser,'cos(cpx)->cpx',op_cos_dc,0,line,0) - call dcl_proc(parser,'cosh(cpx)->cpx',op_cosh_dc,0,line,0) - call dcl_proc(parser,'exp(cpx)->cpx',op_exp_dc,0,line,0) - call dcl_proc(parser,'log(cpx)->cpx',op_log_dc,0,line,0) - call dcl_proc(parser,'sin(cpx)->cpx',op_sin_dc,0,line,0) - call dcl_proc(parser,'sinh(cpx)->cpx',op_sinh_dc,0,line,0) - call dcl_proc(parser,'sqrt(cpx)->cpx',op_sqrt_dc,0,line,0) - call dcl_proc(parser,'tan(cpx)->cpx',op_tan_dc,0,line,0) - call dcl_proc(parser,'tanh(cpx)->cpx',op_tanh_dc,0,line,0) - call dcl_proc(parser,'im(cpx)->real',op_imag_dc,0,line,0) - call dcl_proc(parser,'conj(cpx)->cpx',op_conj_dc,0,line,0) - - ! Cannot convert real to int (must use nint or trunc) - call dcl_uproc(parser,& - 'sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => ''false',line) - call dcl_uproc(parser,& - 'int(x:any_real)=0 :test "Cannot convert real to integer" => ''false',line) - call dcl_uproc(parser,& - 'lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => ''false',line) - - ! Some numeric conversions not hard-coded - call dcl_uproc(parser,'cpx(x:real_num)=cpx(real(x))',line) - call dcl_uproc(parser,'scpx(x:real_num)=cpx(sreal(x))',line) - call dcl_uproc(parser,'string(x:any_int)=string(int64(x))',line) - call dcl_uproc(parser,& - 'string(x:any_cpx)=string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x)',line) - call dcl_uproc(parser,'int(x:fix int)=x',line) - - ! Abstract numeric types - call dcl_type(parser,'any_int is sint,int,lint,int8,int16,int32,int64',& - line) - call dcl_type(parser,'any_real is sreal,real',line) - call dcl_type(parser,'any_cpx is scpx,cpx',line) - call dcl_type(parser,'int_num is any_int',line) - call dcl_type(parser,'real_num is int_num, any_real',line) - call dcl_type(parser,'cpx_num is real_num,any_cpx',line) - call dcl_type(parser,'num is cpx_num',line) - - ! Numeric type conversion - call dcl_uproc(parser,'convert(x,y)=x',line) - call dcl_uproc(parser,'convert(x:int_num,y:sint)=sint(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:int)=int(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:lint)=lint(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:int8)=int8(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:int16)=int16(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:int32)=int32(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:int64)=int64(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:sreal)=sreal(x)',line) - call dcl_uproc(parser,'convert(x:int_num,y:real)=real(x)',line) - call dcl_uproc(parser,'convert(x:real_num,y:cpx)=cpx(x)',line) - call dcl_uproc(parser,'convert(x:real_num,y:scpx)=scpx(x)',line) - - call dcl_uproc(parser,'as(x:int_num,y:)=sint(x)',line) - call dcl_uproc(parser,'as(x:int_num,y:)=int(x)',line) - call dcl_uproc(parser,'as(x:int_num,y:)=lint(x)',line) - call dcl_uproc(parser,'as(x:int_num,y:)=int8(x)',line) - call dcl_uproc(parser,'as(x:int_num,y:)=int16(x)',line) - call dcl_uproc(parser,'as(x:int_num,y:)=int32(x)',line) - call dcl_uproc(parser,'as(x:int_num,y:)=int64(x)',line) - call dcl_uproc(parser,'as(x:real_num,y:)=sreal(x)',line) - call dcl_uproc(parser,'as(x:real_num,y:)=real(x)',line) - call dcl_uproc(parser,'as(x:real_num,y:)=scpx(x)',line) - call dcl_uproc(parser,'as(x:real_num,y:)=cpx(x)',line) - - ! Auto-conversion on assignment - call dcl_uproc(parser,'PM__assign(&x:num,y:num) {_assign_element(&x,convert(y,x))}',line) - call dcl_uproc(parser,'PM__assign_var(&x:num,y:num) {PM__assign(&x,convert(y,x))}',line) - - ! Mixed arithmatic - call dcl_type(parser,'_to_sint is int',line) - call dcl_type(parser,'_to_lint is sint,int',line) - call dcl_type(parser,'_to_int8 is sint,int,lint',line) - call dcl_type(parser,'_to_int16 is sint,int,lint,int8',line) - call dcl_type(parser,'_to_int32 is sint,int,lint,int8,int16',line) - call dcl_type(parser,'_to_int64 is sint,int,lint,int8,int16,int32',line) - call dcl_type(parser,'_to_real is any_int',line) - call dcl_type(parser,'_to_sreal is any_int,real',line) - call dcl_type(parser,'_to_cpx is real_num',line) - call dcl_type(parser,'_to_scpx is real_num,cpx',line) - - call dcl_uproc(parser,'balance(x:sint,y:sint)=x,y',line) - call dcl_uproc(parser,'balance(x:int,y:int)=x,y',line) - call dcl_uproc(parser,'balance(x:lint,y:lint)=x,y',line) - call dcl_uproc(parser,'balance(x:int8,y:int8)=x,y',line) - call dcl_uproc(parser,'balance(x:int16,y:int16)=x,y',line) - call dcl_uproc(parser,'balance(x:int32,y:int32)=x,y',line) - call dcl_uproc(parser,'balance(x:int64,y:int64)=x,y',line) - call dcl_uproc(parser,'balance(x:sreal,y:sreal)=x,y',line) - call dcl_uproc(parser,'balance(x:real,y:real)=x,y',line) - call dcl_uproc(parser,'balance(x:scpx,y:scpx)=x,y',line) - call dcl_uproc(parser,'balance(x:cpx,y:cpx)=x,y',line) - - call dcl_uproc(parser,'balance(x:sint,y:_to_sint)=x,sint(y)',line) - call dcl_uproc(parser,'balance(x:lint,y:_to_lint)=x,lint(y)',line) - call dcl_uproc(parser,'balance(x:int8,y:_to_int8)=x,int8(y)',line) - call dcl_uproc(parser,'balance(x:int16,y:_to_int16)=x,int16(y)',line) - call dcl_uproc(parser,'balance(x:int32,y:_to_int32)=x,int32(y)',line) - call dcl_uproc(parser,'balance(x:int64,y:_to_int64)=x,int64(y)',line) - call dcl_uproc(parser,'balance(x:sreal,y:_to_sreal)=x,sreal(y)',line) - call dcl_uproc(parser,'balance(x:real,y:_to_real)=x,real(y)',line) - call dcl_uproc(parser,'balance(x:scpx,y:_to_scpx)=x,scpx(y)',line) - call dcl_uproc(parser,'balance(x:cpx,y:_to_cpx)=x,cpx(y)',line) - - call dcl_uproc(parser,'balance(x:_to_sint,y:sint)=sint(x),y',line) - call dcl_uproc(parser,'balance(x:_to_lint,y:lint)=lint(x),y',line) - call dcl_uproc(parser,'balance(x:_to_int8,y:int8)=int8(x),y',line) - call dcl_uproc(parser,'balance(x:_to_int16,y:int16)=int16(x),y',line) - call dcl_uproc(parser,'balance(x:_to_int32,y:int32)=int32(x),y',line) - call dcl_uproc(parser,'balance(x:_to_int64,y:int64)=int64(x),y',line) - call dcl_uproc(parser,'balance(x:_to_sreal,y:sreal)=sreal(x),y',line) - call dcl_uproc(parser,'balance(x:_to_real,y:real)=real(x),y',line) - call dcl_uproc(parser,'balance(x:_to_scpx,y:scpx)=scpx(x),y',line) - call dcl_uproc(parser,'balance(x:_to_cpx,y:cpx)=cpx(x),y',line) - - call dcl_uproc(parser,& - 'mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '==(x:num,y:num)=xx==yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '/=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '>=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '>(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '+(x:num,y:num)=xx+yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '-(x:num,y:num)=xx-yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '*(x:num,y:num)=xx*yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '/(x:num,y:num)=xx/yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - '**(x:num,y:num)=xx**yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - 'max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,& - 'min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y)',line) - - ! bool type - call dcl_proc(parser,'PM__assign_var(&bool,bool)',& - op_assign_l,0,line,0) - call dcl_proc(parser,'string(bool)->string',op_string_l,0,line,0) - call dcl_proc(parser,'and(bool,bool)->bool',op_and,0,line,0) - call dcl_proc(parser,'or(bool,bool)->bool',op_or,0,line,0) - call dcl_proc(parser,'not(bool)->bool',op_not,0,line,0) - call dcl_proc(parser,'==(bool,bool)->bool',op_eq_l,0,line,0) - call dcl_proc(parser,'/=(bool,bool)->bool',op_ne_l,0,line,0) - - ! Compile time bool values - call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) - call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) - call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'not(x:''true)=''false',line) - call dcl_uproc(parser,'not(x:''false)=''true',line) - call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) - call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) - call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) - - ! Masked types - call dcl_type(parser,'masked(x) is '//& - 'rec {_val:x,_there:bool}',line) - call dcl_uproc(parser,'|(x:masked,y)=if(x._there=>x._val,y)'//& - 'check "Right operand of ""|"" does not match masked type on the left"=>same_type(x._val,y)',line) - call dcl_uproc(parser,& - 'masked(val,there:bool)=new masked {_val=val,_there=there}',line) - call dcl_uproc(parser,'defined(x:masked)=x._there',line) - call dcl_uproc(parser,'val(x:masked)=x._val '//& - 'check "masked value is undefined"=>x._there',line) - call dcl_uproc(parser,'get(&x,y:masked) {if y._there{x=y._val}}',line) - call dcl_uproc(parser,& - 'get(&x,y:masked(x)) {if y._there{x=y._val};return y._there}',line) - - ! Polymorphic types - call dcl_proc(parser,'get(x:*any,y:any)->=y',op_as,0,line,0) - call dcl_proc(parser,'get(&x:any,y:*any)',op_get_poly,0,line,& - proc_needs_type) - call dcl_proc(parser,'get(&x:any,y:*any)->bool',op_get_poly2,0,line,& - proc_needs_type) - call dcl_proc(parser,'|(x:*any,y:any)->=y',op_get_poly_or,0,line,& - proc_needs_type) - - ! val function having null effect - call dcl_uproc(parser,'val(x)=x',line) - - - ! ******************************************** - ! TUPLES - ! ******************************************** - - ! Tuple types - call dcl_type(parser,& - 'tuple1d(t1) is rec {PM__d1:t1}',line) - call dcl_type(parser,& - 'tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2}',line) - call dcl_type(parser,& - 'tuple3d(t1,t2,t3) is'//& - ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3}',line) - call dcl_type(parser,& - 'tuple4d(t1,t2,t3,t4) is'//& - ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4}',line) - call dcl_type(parser,& - 'tuple5d(t1,t2,t3,t4,t5) is'//& - ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5}',line) - call dcl_type(parser,& - 'tuple6d(t1,t2,t3,t4,t5,t6) is'//& - ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6}',line) - call dcl_type(parser,& - 'tuple7d(t1,t2,t3,t4,t5,t6,t7) is'//& - ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7}',line) - - call dcl_type(parser,'tuple1d_of(t) is tuple1d(t)',line) - call dcl_type(parser,'tuple2d_of(t) is tuple2d(t,t)',line) - call dcl_type(parser,'tuple3d_of(t) is tuple3d(t,t,t)',line) - call dcl_type(parser,'tuple4d_of(t) is tuple4d(t,t,t,t)',line) - call dcl_type(parser,'tuple5d_of(t) is tuple5d(t,t,t,t,t)',line) - call dcl_type(parser,'tuple6d_of(t) is tuple6d(t,t,t,t,t,t)',line) - call dcl_type(parser,'tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t)',line) - - call dcl_type(parser,'tuple(t) is '//& - 'tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),'//& - 'tuple5d(t,t,t,t,t),tuple6d(t,t,t,t,t,t),'//& - 'tuple7d(t,t,t,t,t,t,t)',line) - - call dcl_uproc(parser,'tuple(x)=new tuple1d {PM__d1=x}',line) - call dcl_uproc(parser,'tuple(x,y)='//& - 'new tuple2d {PM__d1=x,PM__d2=y}',line) - call dcl_uproc(parser,'tuple(x,y,z)='//& - 'new tuple3d {PM__d1=x,PM__d2=y,PM__d3=z}',line) - call dcl_uproc(parser,'tuple(x,y,z,t)='//& - 'new tuple4d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t}',line) - call dcl_uproc(parser,'tuple(x,y,z,t,u)='//& - 'new tuple5d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u}',line) - call dcl_uproc(parser,'tuple(x,y,z,t,u,v)='//& - 'new tuple6d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v}',line) - call dcl_uproc(parser,'tuple(x,y,z,t,u,v,w)='//& - 'new tuple7d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w}',line) - - call dcl_uproc(parser,'get_dim(t:tuple1d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple2d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple3d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple4d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple5d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple6d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''1 or [''1])=t.1',line) - call dcl_uproc(parser,'get_dim(t:tuple2d,n:''2 or [''2])=t.2',line) - call dcl_uproc(parser,'get_dim(t:tuple3d,n:''2 or [''2])=t.2',line) - call dcl_uproc(parser,'get_dim(t:tuple4d,n:''2 or [''2])=t.2',line) - call dcl_uproc(parser,'get_dim(t:tuple5d,n:''2 or [''2])=t.2',line) - call dcl_uproc(parser,'get_dim(t:tuple6d,n:''2 or [''2])=t.2',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''2 or [''2])=t.2',line) - call dcl_uproc(parser,'get_dim(t:tuple3d,n:''3 or [''3])=t.3',line) - call dcl_uproc(parser,'get_dim(t:tuple4d,n:''3 or [''3])=t.3',line) - call dcl_uproc(parser,'get_dim(t:tuple5d,n:''3 or [''3])=t.3',line) - call dcl_uproc(parser,'get_dim(t:tuple6d,n:''3 or [''3])=t.3',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''3 or [''3])=t.3',line) - call dcl_uproc(parser,'get_dim(t:tuple4d,n:''4 or [''4])=t.4',line) - call dcl_uproc(parser,'get_dim(t:tuple5d,n:''4 or [''4])=t.4',line) - call dcl_uproc(parser,'get_dim(t:tuple6d,n:''4 or [''4])=t.4',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''4 or [''4])=t.4',line) - call dcl_uproc(parser,'get_dim(t:tuple5d,n:''5 or [''5])=t.5',line) - call dcl_uproc(parser,'get_dim(t:tuple6d,n:''5 or [''5])=t.5',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''5 or [''5])=t.5',line) - call dcl_uproc(parser,'get_dim(t:tuple6d,n:''6 or [''6])=t.6',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''6 or [''6])=t.6',line) - call dcl_uproc(parser,'get_dim(t:tuple7d,n:''7 or [''7])=t.7',line) -!!$ call dcl_uproc(parser,'get_dim(t:tuple,n:fix int)=t.1'//& -!!$ ' :test "tuple subscript out of range" => ''false',line) - - call dcl_uproc(parser,'indices(x:tuple1d)=[''1]',line) - call dcl_uproc(parser,'indices(x:tuple2d)=[''1,''2]',line) - call dcl_uproc(parser,'indices(x:tuple3d)=[''1,''2,''3]',line) - call dcl_uproc(parser,'indices(x:tuple4d)=[''1,''2,''3,''4]',line) - call dcl_uproc(parser,'indices(x:tuple5d)=[''1,''2,''3,''4,''5]',line) - call dcl_uproc(parser,'indices(x:tuple6d)=[''1,''2,''3,''4,''5,''6]',line) - call dcl_uproc(parser,'indices(x:tuple7d)=[''1,''2,''3,''4,''5,''6,''7]',line) - - call dcl_uproc(parser,'full_rank(x:tuple1d)=''1',line) - call dcl_uproc(parser,'full_rank(x:tuple2d)=''2',line) - call dcl_uproc(parser,'full_rank(x:tuple3d)=''3',line) - call dcl_uproc(parser,'full_rank(x:tuple4d)=''4',line) - call dcl_uproc(parser,'full_rank(x:tuple5d)=''5',line) - call dcl_uproc(parser,'full_rank(x:tuple6d)=''6',line) - call dcl_uproc(parser,'full_rank(x:tuple7d)=''7',line) - - call dcl_uproc(parser,'rank(x:tuple)=full_rank(x)',line) - - call dcl_uproc(parser,'reduce(p:proc,x:tuple1d)=x.1',line) - call dcl_uproc(parser,'reduce(p:proc,x:tuple2d)='//& - 'p.(x.2,x.1)',line) - call dcl_uproc(parser,'reduce(p:proc,x:tuple3d)='//& - 'p.(p.(x.3,x.2),x.1)',line) - call dcl_uproc(parser,'reduce(p:proc,x:tuple4d)='//& - 'p.(p.(p.(x.4,x.3),x.2),x.1)',line) - call dcl_uproc(parser,'reduce(p:proc,x:tuple5d)='//& - 'p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1)',line) - call dcl_uproc(parser,'reduce(p:proc,x:tuple6d)='//& - 'p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1)',line) - call dcl_uproc(parser,'reduce(p:proc,x:tuple7d)='//& - 'p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1)',line) - - call dcl_uproc(parser,'map(p:proc,x:tuple1d)='//& - '[p.(x.1)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple2d)='//& - '[p.(x.1),p.(x.2)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple3d)='//& - '[p.(x.1),p.(x.2),p.(x.3)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple4d)='//& - '[p.(x.1),p.(x.2),p.(x.3),p.(x.4)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple5d)='//& - '[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple6d)='//& - '[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple7d)='//& - '[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)]',line) - - call dcl_uproc(parser,'map(p:proc,x:tuple,y:tuple)=error_type()'//& - ' :test "Number of dimensions does not match" => ''false',line) - call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d)='//& - '[p.(x.1,y.1)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d)='//& - '[p.(x.1,y.1),p.(x.2,y.2)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple3d,y:tuple3d)='//& - '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple4d,y:tuple4d)='//& - '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& - 'p.(x.4,y.4)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple5d,y:tuple5d)='//& - '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& - 'p.(x.4,y.4),p.(x.5,y.5)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple6d,y:tuple6d)='//& - '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& - 'p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple7d,y:tuple7d)='//& - '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& - 'p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)]',line) - - call dcl_uproc(parser,'map(p:proc,x:tuple,y:tuple,z:tuple)=error_type()'//& - ' :test "Number of dimensions does not match" => ''false',line) - call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)='//& - '[p.(x.1,y.1,z.1)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)='//& - '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)='//& - '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)='//& - '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& - 'p.(x.4,y.4,z.4)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)='//& - '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& - 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)='//& - '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& - 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)]',line) - call dcl_uproc(parser,'map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)='//& - '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& - 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),'//& - 'p.(x.7,y.7,z.7)]',line) - - call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]'//& - 'where u1,v1=p.(x.1,y.1)',line) - call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]'//& - 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2)',line) - call dcl_uproc(parser,'map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]'//& - 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3)',line) - call dcl_uproc(parser,'map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]'//& - 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4)',line) - call dcl_uproc(parser,'map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]'//& - 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5)',line) - call dcl_uproc(parser,'map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]'//& - 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),'//& - 'u6,v6=p.(x.6,y.6)',line) - call dcl_uproc(parser,'map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]'//& - 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),'//& - 'u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7)',line) - - call dcl_uproc(parser,'map_const(p:proc,x:tuple1d,y)='//& - '[p.(x.1,y)]',line) - call dcl_uproc(parser,'map_const(p:proc,x:tuple2d,y)='//& - '[p.(x.1,y),p.(x.2,y)]',line) - call dcl_uproc(parser,'map_const(p:proc,x:tuple3d,y)='//& - '[p.(x.1,y),p.(x.2,y),p.(x.3,y)]',line) - call dcl_uproc(parser,'map_const(p:proc,x:tuple4d,y)='//& - '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& - 'p.(x.4,y)]',line) - call dcl_uproc(parser,'map_const(p:proc,x:tuple5d,y)='//& - '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& - 'p.(x.4,y),p.(x.5,y)]',line) - call dcl_uproc(parser,'map_const(p:proc,x:tuple6d,y)='//& - '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& - 'p.(x.4,y),p.(x.5,y),p.(x.6,y)]',line) - call dcl_uproc(parser,'map_const(p:proc,x:tuple7d,y)='//& - '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& - 'p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)]',line) - - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple1d)='//& - 'q.(x.1)',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple2d)='//& - 'p.(q.(x.2),q.(x.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple3d)='//& - 'p.(p.(q.(x.3),q.(x.2)),q.(x.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple4d)='//& - 'p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple5d)='//& - 'p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),'//& - 'q.(x.2)),q.(x.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple6d)='//& - 'p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),'//& - 'q.(x.3)),q.(x.2)),q.(x.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple7d)='//& - 'p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),'//& - 'q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1))',line) - - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type()'//& - ' :test "Number of dimensions does not match" => ''false',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)='//& - 'q.(x.1,y.1)',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)='//& - 'p.(q.(x.2,y.2),q.(x.1,y.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)='//& - 'p.(p.(q.(x.3,y.3),q.(x.2,y.2)),'//& - 'q.(x.1,y.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)='//& - 'p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),'//& - 'q.(x.1,y.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)='//& - 'p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),'//& - 'q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)='//& - 'p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),'//& - 'q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)='//& - 'p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),'//& - 'q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1))',line) - - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type()'//& - ' :test "Number of dimensions does not match" => ''false',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)='//& - 'q.(x.1,y.1,z.1)',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)='//& - 'p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)='//& - 'p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),'//& - 'q.(x.1,y.1,z.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)='//& - 'p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),'//& - 'q.(x.1,y.1,z.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)='//& - 'p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),'//& - 'q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)='//& - 'p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),'//& - 'q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1))',line) - call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)='//& - 'p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),'//& - 'q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1))',line) - - call dcl_uproc(parser,'apply(p:proc,x:tuple1d)='//& - 'p.(x.1)',line) - call dcl_uproc(parser,'apply(p:proc,x:tuple2d)='//& - 'p.(x.1,x.2)',line) - call dcl_uproc(parser,'apply(p:proc,x:tuple3d)='//& - 'p.(x.1,x.2,x.3)',line) - call dcl_uproc(parser,'apply(p:proc,x:tuple4d)='//& - 'p.(x.1,x.2,x.3,x.4)',line) - call dcl_uproc(parser,'apply(p:proc,x:tuple5d)='//& - 'p.(x.1,x.2,x.3,x.4,x.5)',line) - call dcl_uproc(parser,'apply(p:proc,x:tuple6d)='//& - 'p.(x.1,x.2,x.3,x.4,x.5,x.6)',line) - call dcl_uproc(parser,'apply(p:proc,x:tuple7d)='//& - 'p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7)',line) - - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple1d)='//& - 'p.(q.(x.1))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple2d)='//& - 'p.(q.(x.1),q.(x.2))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple3d)='//& - 'p.(q.(x.1),q.(x.2),q.(x.3))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple4d)='//& - 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple5d)='//& - 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),'//& - 'q.(x.5))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple6d)='//& - 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),'//& - 'q.(x.5),q.(x.6))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple7d)='//& - 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),'//& - 'q.(x.5),q.(x.6),q.(x.7))',line) - - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type()'//& - ':test "Number of dimensions does not match" => ''false',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)='//& - 'p.(q.(x.1,y.1))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)='//& - 'p.(q.(x.1,y.1),q.(x.2,y.2))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)='//& - 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)='//& - 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)='//& - 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),'//& - 'q.(x.5,y.5))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)='//& - 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),'//& - 'q.(x.5,y.5),q.(x.6,y.6))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)='//& - 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),'//& - 'q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7))',line) - - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)='//& - 'error_type() :test "Number of dimensions does not match" => ''false',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)='//& - 'p.(q.(x.1,y.1,z.1))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)='//& - 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)='//& - 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)='//& - 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)='//& - 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),'//& - 'q.(x.5,y.5,z.5))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)='//& - 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),'//& - 'q.(x.5,y.5,z.5),q.(x.6,y.6,z.6))',line) - call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)='//& - 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),'//& - 'q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7))',line) - - - call dcl_uproc(parser,'scan(p:proc,x:tuple1d)=x.1',line) - call dcl_uproc(parser,'scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)]',line) - call dcl_uproc(parser,'scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)]'//& - ' where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)]'//& - ' where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)]'//& - ' where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)]'//& - ' where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) '//& - ' where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)]'//& - ' where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) '//& - ' where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) - - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple1d,x0)=x0',line) - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1]',line) - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)]',line) - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)]'//& - ' where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)]'//& - ' where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)]'//& - ' where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) - call dcl_uproc(parser,'pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)]'//& - ' where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) '//& - ' where x2=p.(x.1,x.2)',line) - - call dcl_type(parser,'empty_head is unique',line) - call dcl_uproc(parser,'head(x:null)=empty_head',line) - call dcl_uproc(parser,'head(x:tuple)=x.1',line) - - call dcl_uproc(parser,'tail(x:null)=null',line) - call dcl_uproc(parser,'tail(x:tuple1d)=null',line) - call dcl_uproc(parser,'tail(x:tuple2d)=[x.2]',line) - call dcl_uproc(parser,'tail(x:tuple3d)=[x.2,x.3]',line) - call dcl_uproc(parser,'tail(x:tuple4d)=[x.2,x.3,x.4]',line) - call dcl_uproc(parser,'tail(x:tuple5d)=[x.2,x.3,x.4,x.5]',line) - call dcl_uproc(parser,'tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6]',line) - call dcl_uproc(parser,'tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7]',line) - - call dcl_uproc(parser,'prepend(y,x:null)=[y]',line) - call dcl_uproc(parser,'prepend(y,x:tuple1d)=[y,x.1]',line) - call dcl_uproc(parser,'prepend(y,x:tuple2d)=[y,x.1,x.2]',line) - call dcl_uproc(parser,'prepend(y,x:tuple3d)=[y,x.1,x.2,x.3]',line) - call dcl_uproc(parser,'prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4]',line) - call dcl_uproc(parser,'prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5]',line) - call dcl_uproc(parser,'prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6]',line) - call dcl_uproc(parser,& - 'prepend(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => ''false',line) - - call dcl_uproc(parser,'append(x:null,y)=[y]',line) - call dcl_uproc(parser,'append(x:tuple1d,y)=[x.1,y]',line) - call dcl_uproc(parser,'append(x:tuple2d,y)=[x.1,x.2,y]',line) - call dcl_uproc(parser,'append(x:tuple3d,y)=[x.1,x.2,x.3,y]',line) - call dcl_uproc(parser,'append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y]',line) - call dcl_uproc(parser,'append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y]',line) - call dcl_uproc(parser,'append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y]',line) - call dcl_uproc(parser,& - 'append(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => ''false',line) - - call dcl_uproc(parser,'elems(x:tuple1d)=x.1',line) - call dcl_uproc(parser,'elems(x:tuple2d)=x.1,x.2',line) - call dcl_uproc(parser,'elems(x:tuple3d)=x.1,x.2,x,3',line) - call dcl_uproc(parser,'elems(x:tuple4d)=x.1,x.2,x.3,x.4',line) - call dcl_uproc(parser,'elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5',line) - call dcl_uproc(parser,'elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6',line) - call dcl_uproc(parser,'elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7',line) - - call dcl_uproc(parser,'replace(x:tuple1d,y:''1,z)=[z]',line) - call dcl_uproc(parser,'replace(x:tuple2d,y:''1,z)=[z,x.2]',line) - call dcl_uproc(parser,'replace(x:tuple3d,y:''1,z)=[z,x.2,x.3]',line) - call dcl_uproc(parser,'replace(x:tuple4d,y:''1,z)=[z,x.2,x.3,x.4]',line) - call dcl_uproc(parser,'replace(x:tuple5d,y:''1,z)=[z,x.2,x.3,x.4,x.5]',line) - call dcl_uproc(parser,'replace(x:tuple6d,y:''1,z)=[z,x.2,x.3,x.4,x.5,x.6]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''1,z)=[z,x.2,x.3,x.4,x.5,x.6,x.7]',line) - call dcl_uproc(parser,'replace(x:tuple2d,y:''2,z)=[x.1,z]',line) - call dcl_uproc(parser,'replace(x:tuple3d,y:''2,z)=[x.1,z,x.3]',line) - call dcl_uproc(parser,'replace(x:tuple4d,y:''2,z)=[x.1,z,x.3,x.4]',line) - call dcl_uproc(parser,'replace(x:tuple5d,y:''2,z)=[x.1,z,x.3,x.4,x.5]',line) - call dcl_uproc(parser,'replace(x:tuple6d,y:''2,z)=[x.1,z,x.3,x.4,x.5,x.6]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''2,z)=[x.1,z,x.3,x.4,x.5,x.6,x.7]',line) - call dcl_uproc(parser,'replace(x:tuple3d,y:''3,z)=[x.1,x.2,z]',line) - call dcl_uproc(parser,'replace(x:tuple4d,y:''3,z)=[x.1,x.2,z,x.4]',line) - call dcl_uproc(parser,'replace(x:tuple5d,y:''3,z)=[x.1,x.2,z,x.4,x.5]',line) - call dcl_uproc(parser,'replace(x:tuple6d,y:''3,z)=[x.1,x.2,z,x.4,x.5,x.6]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''3,z)=[x.1,x.2,z,x.4,x.5,x.6,x.7]',line) - call dcl_uproc(parser,'replace(x:tuple4d,y:''4,z)=[x.1,x.2,x.3,z]',line) - call dcl_uproc(parser,'replace(x:tuple5d,y:''4,z)=[x.1,x.2,x.3,z,x.5]',line) - call dcl_uproc(parser,'replace(x:tuple6d,y:''4,z)=[x.1,x.2,x.3,z,x.5,x.6]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''4,z)=[x.1,x.2,x.3,z,x.5,x.6,x.7]',line) - call dcl_uproc(parser,'replace(x:tuple5d,y:''5,z)=[x.1,x.2,x.3,x.4,z]',line) - call dcl_uproc(parser,'replace(x:tuple6d,y:''5,z)=[x.1,x.2,x.3,x.4,z,x.6]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''5,z)=[x.1,x.2,x.3,x.4,z,x.6,x.7]',line) - call dcl_uproc(parser,'replace(x:tuple6d,y:''6,z)=[x.1,x.2,x.3,x.4,x.5,z]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''6,z)=[x.1,x.2,x.3,x.4,x.5,z,x.7]',line) - call dcl_uproc(parser,'replace(x:tuple7d,y:''7,z)=[x.1,x.2,x.3,x.4,x.5,x.6,z]',line) - - call dcl_uproc(parser,'spread(x,y:tuple1d or ''1)=[x]',line) - call dcl_uproc(parser,'spread(x,y:tuple2d or ''2)=[x,x]',line) - call dcl_uproc(parser,'spread(x,y:tuple3d or ''3)=[x,x,x]',line) - call dcl_uproc(parser,'spread(x,y:tuple4d or ''4)=[x,x,x,x]',line) - call dcl_uproc(parser,'spread(x,y:tuple5d or ''5)=[x,x,x,x,x]',line) - call dcl_uproc(parser,'spread(x,y:tuple6d or ''6)=[x,x,x,x,x,x]',line) - call dcl_uproc(parser,'spread(x,y:tuple7d or ''7)=[x,x,x,x,x,x,x]',line) - - call dcl_uproc(parser,'+(x:tuple(num),y:tuple(num))=map($+,x,y)',line) - call dcl_uproc(parser,'-(x:tuple(num),y:tuple(num))=map($-,x,y)',line) - call dcl_uproc(parser,'*(x:tuple(num),y:tuple(num))=map($*,x,y)',line) - call dcl_uproc(parser,'/(x:tuple(num),y:tuple(num))=map($/,x,y)',line) - call dcl_uproc(parser,'**(x:tuple(num),y:tuple(num))=map($**,x,y)',line) - call dcl_uproc(parser,'mod(x:tuple(num),y:tuple(num))=map($mod,x,y)',line) - - call dcl_uproc(parser,'+(x:tuple(num),y:num)=map_const($+,x,y)',line) - call dcl_uproc(parser,'-(x:tuple(num),y:num)=map_const($-,x,y)',line) - call dcl_uproc(parser,'*(x:tuple(num),y:num)=map_const($*,x,y)',line) - call dcl_uproc(parser,'/(x:tuple(num),y:num)=map_const($/,x,y)',line) - call dcl_uproc(parser,'**(x:tuple(num),y:num)=map_const($**,x,y)',line) - call dcl_uproc(parser,'mod(x:tuple(num),y:num)=map_const($mod,x,y)',line) - - call dcl_uproc(parser,'max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y)',line) - call dcl_uproc(parser,'min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y)',line) - call dcl_uproc(parser,'max(x:tuple(real_num))=reduce($max,x)',line) - call dcl_uproc(parser,'min(x:tuple(real_num))=reduce($min,x)',line) - call dcl_uproc(parser,'sum(x:tuple(num))=reduce($+,x)',line) - call dcl_uproc(parser,'prod(x:tuple(num))=reduce($*,x)',line) - - call dcl_uproc(parser,'sint(x:tuple(num))=map($sint,x)',line) - call dcl_uproc(parser,'int(x:tuple(num))=map($int,x)',line) - call dcl_uproc(parser,'sreal(x:tuple(num))=map($sreal,x)',line) - call dcl_uproc(parser,'real(x:tuple(num))=map($real,x)',line) - - call dcl_uproc(parser,'string(x:tuple1d)="[ "++x.1++" ]"',line) - call dcl_uproc(parser,'string(x:tuple2d)="[ "++x.1++", "++x.2++" ]"',line) - call dcl_uproc(parser,'string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]"',line) - call dcl_uproc(parser,'string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]"',line) - call dcl_uproc(parser,& - 'string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]"',line) - call dcl_uproc(parser,'string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++'//& - '", "++x.6++" ]"',line) - call dcl_uproc(parser,'string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++'//& - '", "++x.6++", "++x.7++" ]"',line) - - ! ***************************************************** - ! RANGES AND SEQUENCES - ! ***************************************************** - - ! Treat null as empty sequence in some cases - call dcl_uproc(parser,'in(x,y:null)=''false',line) - call dcl_uproc(parser,'in(x:null,y:null)=''true',line) - - ! Range base type (might later expand to interface) - call dcl_type(parser,'range_base is real_num',line) - - ! Single point sequence - call dcl_type(parser,'single_point(t:range_base) is rec {_t:t}',line) - call dcl_uproc(parser,'single_point(x)=new single_point {_t=x}',line) - call dcl_uproc(parser,'low(x:single_point)=x._t',line) - call dcl_uproc(parser,'high(x:single_point)=x._t',line) - call dcl_uproc(parser,'step(x:single_point)=x._t',line) - call dcl_uproc(parser,'width(x:single_point)=''1',line) - call dcl_uproc(parser,'norm(x:single_point)=x',line) - call dcl_uproc(parser,'#(x:single_point)=shape([''0..''0])',line) - call dcl_uproc(parser,'_shp(x:single_point)=''0..''0',line) - call dcl_uproc(parser,'dims(x:single_point)=[''1]',line) - call dcl_uproc(parser,'size(x:single_point)=''1',line) - call dcl_uproc(parser,'+(x:single_point,y:range_base)=new single_point {_t=x._t+y}',line) - call dcl_uproc(parser,'-(x:single_point,y:range_base)=new single_point {_t=x._t-y}',line) - call dcl_uproc(parser,'*(x:single_point,y:range_base)=new single_point {_t=x._t*y}',line) - call dcl_uproc(parser,'_arb(x:single_point)=x._t',line) - call dcl_uproc(parser,'in(x:range_base,y:single_point)=x==y._t',line) - call dcl_uproc(parser,' inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t',line) - !call dcl_uproc(parser,' inc(x:seq,y:single_point)=y._t in x',line) - call dcl_uproc(parser,'convert(x:single_point,y:range_base)=single_point(convert(x._t,y))',line) - call dcl_uproc(parser,'sint(x:single_point)=single_point(sint(x._t))',line) - call dcl_uproc(parser,'int(x:single_point)=single_point(int(x._t))',line) - call dcl_uproc(parser,'sreal(x:single_point)=single_point(sreal(x._t))',line) - call dcl_uproc(parser,'real(x:single_point)=single_point(real(x._t))',line) - call dcl_uproc(parser,'#(x:single_point,y:index)=''0',line) - call dcl_uproc(parser,'#(x:single_point,y:grid_slice_dim)=''0..''0',line) - call dcl_uproc(parser,'#(x:single_point,y:single_point)=''0..''0',line) - call dcl_uproc(parser,'#(x:grid_slice_dim,y:single_point)=xx..xx where xx=x#y._t',line) - call dcl_uproc(parser,'overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1)',line) - call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1)',line) - call dcl_uproc(parser,'overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1)',line) - call dcl_uproc(parser,'intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1)',line) - call dcl_uproc(parser,'intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1)',line) - call dcl_uproc(parser,'intersect(x:single_point(any_int),y:single_point(any_int))='//& - 'x._t..if(x._t==y._t=>x._t,x._t-1)',line) - - call dcl_uproc(parser,'_get_elem(x:single_point,y:index)=x._t',line) - call dcl_uproc(parser,'_get_elem(x:single_point,y:subs)=x._t..x._t',line) - call dcl_uproc(parser,'string(x:single_point)=string(x._t)',line) - - ! Range types - call dcl_type(parser,'range(t:range_base) is rec {_lo:t,_hi:t,_n:t}',line) - call dcl_uproc(parser,'..(x:range_base,y:range_base)='//& - 'new range {_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& - 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) - call dcl_uproc(parser,'low(x:range)=x._lo',line) - call dcl_uproc(parser,'high(x:range)=x._hi',line) - call dcl_uproc(parser,'step(x:range)=convert(1,x._lo)',line) - call dcl_uproc(parser,'width(x:range)=''1',line) - call dcl_uproc(parser,'norm(x:range)=x',line) - call dcl_uproc(parser,'#(x:range(int))=shape([0..x._n-1])',line) - call dcl_uproc(parser,'_shp(x:range(int))=0..x._n-1',line) - call dcl_uproc(parser,'dims(x:range(int))=[x._n]',line) - call dcl_uproc(parser,& - 'size(x:range(int))=x._n',line) - call dcl_uproc(parser,'+(x:range,y:range_base)=new range {_lo=x._lo+y,_hi=x._hi+y,_n=x._n}',line) - call dcl_uproc(parser,'-(x:range,y:range_base)=new range {_lo=x._lo-y,_hi=x._hi-y,_n=x._n}',line) -!!$ call dcl_uproc(parser,'*(x:range,y:range_base)=new range {_lo=x._lo*y,_hi=x._hi*y,_n=x._n}',line) - call dcl_uproc(parser,& - '_arb(x:range)=low(x)',line) - call dcl_uproc(parser,& - 'in(x:range_base,y:range())=x>=y._lo and x<=y._hi',line) - call dcl_uproc(parser,'convert(x:range,y:range_base)='//& - 'new range {_lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n}',line) - call dcl_uproc(parser,& - 'sint(x:range)=new range {_lo=sint(x._lo),_hi=sint(x._hi),_n=x._n}',line) - call dcl_uproc(parser,& - 'int(x:range)=new range {_lo=int(x._lo),_hi=int(x._hi),_n=x._n}',line) - call dcl_uproc(parser,& - 'sreal(x:range)=new range {_lo=sreal(x._lo),_hi=sreal(x._hi)}',line) - call dcl_uproc(parser,'real(x:range)='//& - 'new range {_lo=real(x._lo),_hi=real(x._hi),_n=x._n}',line) - call dcl_uproc(parser,& - ' inc(x:range,y:seq())='//& - ' low(y)>=x._lo and high(y)<=x._hi',line) - call dcl_uproc(parser,& - '_get_elem(x:range,y:int)=x._lo+convert(y,x._lo)',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:range(int))='//& - '_get_elem(x,y._lo).._get_elem(x,y._hi)',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:seq(int))='//& - '_get_elem(x,y._lo).._get_elem(x,y._hi) by y._st',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:range_above(int))='//& - '_get_elem(x,y._t)..x._hi',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:range_below(int))='//& - 'x._lo.._get_elem(x,y._t)',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:strided_range_above(int))='//& - '_get_elem(x,y._t)..x._hi by y._st',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:strided_range_below(int))='//& - 'x._lo .. _get_elem(x,y._t) by y._st',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:stride(int))=x by y._st',line) - call dcl_uproc(parser,& - '_get_elem(x:range,y:null)=x',line) - call dcl_uproc(parser,& - '#(y:range(int),x:int)=int(x-y._lo)',line) - call dcl_uproc(parser,'#(y:range(int),x:range(int))='//& - 'int(x._lo-y._lo)..int(x._hi-y._lo)',line) - call dcl_uproc(parser,'#(y:range(int),x:seq(int))='//& - '_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st)',line) - call dcl_uproc(parser,& - '#(y:range(int),x:range_below(int))='//& - '0..int(x._t-y._lo)',line) - call dcl_uproc(parser,& - '#(y:range(int),x:range_above(int))='//& - 'int(x._t-y._lo)..size(y)-1',line) - call dcl_uproc(parser,'#(y:range(int),x:strided_range_below(int))='//& - '_intseq(0,int(x._t-y._lo),x._st)',line) - call dcl_uproc(parser,'#(y:range(int),x:strided_range_above(int))='//& - '_intseq(int(x._t-y._lo),size(y)-1,int(x._st))',line) - call dcl_uproc(parser,'#(y:range(int),x:stride(int))='//& - '_intseq(0,size(y),int(x._st))',line) - call dcl_uproc(parser,'#(y:range(int),x:null)=0..size(y)',line) - call dcl_uproc(parser,'intersect(x:range(int),y:range(int))='//& - 'max(y._lo,x._lo)..min(y._hi,x._hi)',line) - call dcl_uproc(parser,'overlap(x:range(int),y:range(int))='//& - 'max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo',line) - - call dcl_uproc(parser,'expand(x:range(),y:range())='//& - 'x._lo+y._lo..x._hi+y._hi',line) - call dcl_uproc(parser,'contract(x:range(),y:range())='//& - 'x._lo-y._lo..x._hi-y._hi',line) - call dcl_uproc(parser,'empty(x:range)=new range {_lo=x._hi,_hi=x._lo,_n=0}',line) - call dcl_uproc(parser,'string(x:range)=string(x._lo)++".."++(x._hi)',line) - - ! Strided range types - call dcl_type(parser,& - 'strided_range(t) is rec {_lo:t,_hi:t,_st:t,_n:int}',line) - call dcl_type(parser,& - '_any_seq(t:range_base):indexable is strided_range(t), ... ',line) - call dcl_type(parser,& - '_any_seq(t:any_int) is ..., range(t),single_point(t)',line) - call dcl_type(parser,'seq(t:range_base) is _any_seq(t)',line) - call dcl_uproc(parser,'_seq(lo,hi,st)=new strided_range {_lo=lo,_hi=lo+n*st,_st=st,_n=n}'//& - 'where n=max(0,int((hi-lo)/st))',line) - call dcl_uproc(parser,'by(x:range(int),y:range_base)=_seq(lo,hi,st)'//& - ' where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y)',line) - call dcl_uproc(parser,'by(x:seq,y:range_base)=_seq(lo,hi,st) where'//& - ' lo=convert(x._lo,st),hi=convert(x._hi,st)'//& - ' where st=x._st*y',line) - call dcl_uproc(parser,'_intseq(x:int,y:int,st:int)='//& - ' new strided_range {_lo=x,_hi=x+n*s,_st=s,_n=n}'//& - ' where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st)',line) - call dcl_uproc(parser,'low(x:strided_range)=x._lo',line) - call dcl_uproc(parser,'high(x:strided_range)=x._hi',line) - call dcl_uproc(parser,'step(x:strided_range)=x._st',line) - call dcl_uproc(parser,'size(x:strided_range)=x._n',line) - call dcl_uproc(parser,'width(x:strided_range)=''1',line) - call dcl_uproc(parser,'norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)'//& - 'where hi=lo+(x._n-1)*x._st where lo=x._lo',line) - call dcl_uproc(parser,'align(x:seq)=''0',line) - call dcl_uproc(parser,'#(x:strided_range)=shape([0..x._n-1])',line) - call dcl_uproc(parser,'_shp(x:strided_range)=0..x._n-1',line) - call dcl_uproc(parser,'dims(x:strided_range)=[x._n]',line) - call dcl_uproc(parser,'+(x:strided_range,y:range_base)='//& - 'new strided_range {_lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n}',line) - call dcl_uproc(parser,'-(x:strided_range,y:range_base)='//& - 'new strided_range {_lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n}',line) -!!$ call dcl_uproc(parser,'*(x:strided_range,y:range_base)='//& -!!$ 'new strided_range {_lo=x._lo*y,_hi=x._hi*y,_st=x._st*y,_n=x._n}',line) - call dcl_uproc(parser,'_arb(x:seq)=x._lo',line) - call dcl_uproc(parser,'convert(x:strided_range,y:range_base)='//& - 'new strided_range {_lo=convert(x._lo,y),_hi=convert(x._hi,y),'//& - '_st=convert(x._st,y),_n=x._n}',line) - call dcl_uproc(parser,'sint(x:strided_range)='//& - 'new strided_range {_lo=sint(x._lo),_hi=sint(x._hi),'//& - '_st=sint(x._st),_n=x._n}',line) - call dcl_uproc(parser,'int(x:strided_range)='//& - 'new strided_range {_lo=int(x._lo),_hi=int(x._hi),'//& - '_st=int(x._st),_n=x._n}',line) - call dcl_uproc(parser,'sreal(x:strided_range)='//& - 'new strided_range {_lo=sreal(x._lo),_hi=sreal(x._hi),'//& - '_st=sreal(x._st),_n=x._n}',line) - call dcl_uproc(parser,'real(x:strided_range)='//& - 'new strided_range {_lo=real(x._lo),_hi=real(x._hi),'//& - '_st=real(x._st),_n=x._n}',line) - call dcl_uproc(parser,& - 'in(x:int,y:strided_range(int))='//& - 'y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0',line) - call dcl_uproc(parser,& - 'inc(x:strided_range(int),y:strided_range(int))='//& - 'y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x)',line) - call dcl_uproc(parser,& - 'inc(x:strided_range(int),y:range(int) or single_point(int))='//& - 'x inc low(y)..high(y) by 1',line) - call dcl_uproc(parser,& - '#(y:seq,x:range_base)=int((x-y._lo+y._a)/y._st)',line) - call dcl_uproc(parser,& - '#(y:seq,x:range)=y#x._lo..y#x._hi',line) - call dcl_uproc(parser,& - '#(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) '//& - ' where lo=y#x._lo,hi=y#x._hi',line) - call dcl_uproc(parser,& - '#(y:seq,x:range_below)=0..y#x._t',line) - call dcl_uproc(parser,& - '#(y:seq,x:range_above)=y#x._t..size(y)-1',line) - call dcl_uproc(parser,& - '#(y:seq,x:strided_range_below)='//& - '_intseq(0,y#x._t,int((x._st+y._st/2)/y._st))',line) - call dcl_uproc(parser,& - '#(y:seq,x:strided_range_above)='//& - '_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st))',line) - call dcl_uproc(parser,& - '#(y:seq,x:stride)=_intseq(0,size(y),int((x._st+y._st/2)/y._st))',line) - call dcl_uproc(parser,& - '#(y:seq,x:null)=0..size(y)-1',line) - call dcl_uproc(parser,'string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st',line) - - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:range(int))='//& - '_seq(_get_elem(x,y._lo),_get_elem(x,y._hi),x._st)',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:seq(int))='//& - '_seq(_get_elem(x,y._lo),_get_elem(x,y._hi),'//& - 'convert(st*y._st,st)) where st=x._st',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:range_above(int))='//& - '_seq(_get_elem(x,y._t),x._hi,x._st)',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:range_below(int))='//& - '_seq(x._lo,_get_elem(x,y._t),x._st)',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:strided_range_above(int))='//& - '_seq(_get_elem(x,y._t),x._hi,convert(st*y._st,st)) where st=x._st',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:strided_range_below(int))='//& - '_seq(x._lo,_get_elem(x,y._t),convert(st*y._st,st)) where st=x._st',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:stride(int))=x by y',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:null)=x',line) - - call dcl_uproc(parser,& - 'overlap(x:strided_range(any_int),y:range(any_int))='//& - ' max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st)',line) - call dcl_uproc(parser,& - 'overlap(x:range(any_int),y:strided_range(any_int))='//& - 'max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo',line) !!! WRONG - call dcl_uproc(parser,& - 'intersect(x:strided_range(any_int),y:range(any_int))='//& - 'x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st'//& - ' where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st',line) - call dcl_uproc(parser,& - 'intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x)',line) - - call dcl_proc(parser,& - '_intersect_seq(int,int,int,int,int,int,int,int)->int,int,int,int',& - op_intersect_seq,0,line,0) - call dcl_uproc(parser,'intersect(x:strided_range(any_int),y:strided_range(any_int))='//& - 'new strided_range {_lo=lo,_hi=hi,_st=st,_n=n}'//& - 'where lo,hi,st,n='//& - '_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& - 'int(y._lo),int(y._hi),int(y._st),int(y._n))',line) - call dcl_uproc(parser,'overlap(x:strided_range(any_int),y:strided_range(any_int))='//& - 'new strided_range {_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=st/x._st,_n=n}'//& - ' where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& - ' int(y._lo),int(y._hi),int(y._st),int(y._n))',line) - call dcl_uproc(parser,'empty(x:strided_range(any_int))='//& - 'new strided_range {_lo=x._hi,_hi=x._lo,_st=x._st,_n=0}',line) - - ! Block sequence - call dcl_type(parser,& - 'block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int}',line) - call dcl_uproc(parser,'block_seq(lo:int,hi:int,st:int,b:int,align:int){'//& - 'test "Block sequence width must be non-negative: "++b=>b>=0;'//& - 'test "Block sequence width must be less than step: "++b++">="++st=>b<=st;'//& - 'test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1)',line) - call dcl_uproc(parser,'last_block(x:block_seq)=low..min(low+x._b,x._hi) '//& - 'where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st',line) - call dcl_uproc(parser,'middle_blocks(x:block_seq)=new block_seq {'//& - '_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}'//& - 'where nb=(x._hi-low+x._st-x._b+1)/x._st '//& - 'where low=if(x._align==0=>x._lo,x._lo-x._align+x._st)',line) - call dcl_uproc(parser,& - 'string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align',& - line) - call dcl_uproc(parser,'low(x:block_seq)=x._lo',line) - call dcl_uproc(parser,'high(x:block_seq)=x._hi',line) - call dcl_uproc(parser,'step(x:block_seq)=x._st',line) - call dcl_uproc(parser,'width(x:block_seq)=x._b',line) - call dcl_uproc(parser,'norm(x:block_seq)=x',line) - call dcl_uproc(parser,'align(x:block_seq)=x._align',line) - call dcl_uproc(parser,'#(x:block_seq)=shape([0..x._n-1])',line) - call dcl_uproc(parser,'_shp(x:block_seq)=0..x._n-1',line) - call dcl_uproc(parser,'dims(x:block_seq)=x._n',line) - call dcl_uproc(parser,'size(x:block_seq)=x._n',line) - call dcl_uproc(parser,'+(x:block_seq,y:int)='//& - 'new block_seq {_lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align}',line) - call dcl_uproc(parser,'-(x:block_seq,y:int)='//& - 'new block_seq {_lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align}',line) -!!$ call dcl_uproc(parser,'*(x:block_seq,y:int)='//& !!! Not sure this is right definition !! -!!$ 'new block_seq {_lo=x._lo*y,_hi=x._hi*y,_st=x._st*y,_b=x._b*y,_n=x._n,_align=x._align*y}',line) - call dcl_uproc(parser,'_arb(x:block_seq)=x._lo',line) - call dcl_uproc(parser,'in(x:int,y:block_seq)='//& - 'x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo:=nblo+x._st;'//& - ' if hi-nbhi>=x._b:hi:=nbhi+x._b-1;'//& - ' align=base-(base/x._st)*x._st '//& - ' where base=lo-oldbase;'//& - ' return block_seq(lo,hi,x._st,x._b,align)'//& - '}',line) - call dcl_uproc(parser,'intersect(x:range(any_int),y:block_seq)=intersect(y,x)',line) - call dcl_uproc(parser,'overlap(x:range(any_int),y:block_seq) {'//& - 'z=intersect(y,x);'//& - 'return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align)}',line) - call dcl_uproc(parser,'overlap(x:block_seq,y:range(any_int)) {'//& - 'z=intersect(x,y);'//& - 'return start..start+size(z)-1 where start=z#z._lo}',line) - call dcl_uproc(parser,'overlap(x:block_seq,y:range(any_int)) {'//& - 'z=intersect(x,y);'//& - 'return start..start+size(z)-1,'//& - ' block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align)'//& - ' where start=z#z._lo}',line) - call dcl_uproc(parser,'overlap(x:range(any_int),y:block_seq)=yy,xx'//& - ' where xx,yy=overlap(x,y)',line) - call dcl_uproc(parser,'empty(x:block_seq)=block_seq(1,0,1,1,0)',line) - - ! Mapped sequence - call dcl_type(parser,'map_seq(t:array(int)) is rec {array:t}',line) - call dcl_uproc(parser,'map_seq(x:grid_dim){var a=array(0,#x);for i in a,j in x <>:i:=j;'//& - 'return new map_seq{array=a}}',line) - call dcl_uproc(parser,'map_seq(x:array(int,mshape1d))=new map_seq {array=x} '//& - 'check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x)',line) - call dcl_uproc(parser,'_mono(x) {xs=#x;var ok=true;'//& - 'if x[low(xs.1)]x[i-1]:sync ok:=false};return ok}' ,line) - - call dcl_uproc(parser,'map_seq(x:map_seq)=x',line) - - call dcl_uproc(parser,'#(x:map_seq)=#(x.array)',line) - call dcl_uproc(parser,'_shp(x:map_seq)=0..size(x.array)-1',line) - call dcl_uproc(parser,'dims(x:map_seq)=size(x.array)',line) - call dcl_uproc(parser,'size(x:map_seq)=size(x.array)',line) - call dcl_uproc(parser,'+(x:map_seq,y:range_base)=new map_seq{array=x.array+y}',line) - call dcl_uproc(parser,'-(x:map_seq,y:range_base)=new map_seq{array=x.array-y}',line) - call dcl_uproc(parser,'*(x:map_seq,y:range_base)=new map_seq{array=x.array*y}',line) - - call dcl_uproc(parser,'_arb(x:map_seq)=_arb(x.array)',line) - call dcl_uproc(parser,'_get_elem(x:map_seq,y:int)=_get_elem(x.array,y)',line) - - call dcl_proc(parser,'_intersect_aseq(&any,any,any,any,any,&any)',& - op_intersect_aseq,0,line,0) - call dcl_proc(parser,'_overlap_aseq(&any,any,any,any,any,&any)',& - op_intersect_aseq,1,line,0) - call dcl_proc(parser,'_overlap_aseq2(&any,any,any,any,any,&any,&any)',& - op_intersect_aseq,2,line,0) - call dcl_proc(parser,'_expand_aseq(&any,any,any,&any,any,any)',& - op_expand_aseq,0,line,0) - call dcl_proc(parser,'_intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any)',& - op_intersect_bseq,0,line,0) - call dcl_proc(parser,'_overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any)',& - op_intersect_bseq,1,line,0) - call dcl_proc(parser,'_overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any)',& - op_intersect_bseq,2,line,0) - call dcl_proc(parser,'_includes_aseq(any,any,any,any)->bool',& - op_includes_aseq,0,line,0) - call dcl_proc(parser,'_index_aseq(any,any,any)->int',& - op_index_aseq,0,line,0) - call dcl_proc(parser,'_in_aseq(any,any,any)->bool',& - op_in_aseq,0,line,0) - -!!$ call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq) {'//& -!!$ 'var a=array(0,[0..min(x._n,y._n)-1]);'//& -!!$ 'var n=0;_intersect_bseq(&n,a,x._lo,x._hi,x._b,x._st,x._align,'//& -!!$ 'y._lo,y._hi,y._b,y._st,y._align);'//& -!!$ 'v=new map_seq {array=a[0..n-1]};return v}',line) -!!$ -!!$ call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq) {'//& -!!$ 'var a=array(0,[0..min(x._n,y._n)-1]);'//& -!!$ 'var n=0;_overlap_bseq(&n,a,x._lo,x._hi,x._b,x._st,x._align,'//& -!!$ 'y._lo,y._hi,y._b,y._st,y._align);'//& -!!$ 'v=new map_seq {array=a[0..n-1]};return v}',line) -!!$ -!!$ call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq) {'//& -!!$ 'm=[0..min(x._n,y._n)-1];var a=array(0,m);var b=array(0,m);'//& -!!$ 'var n=0;_overlap_bseq2(&n,a,b,x._lo,x._hi,x._b,x._st,x._align,'//& -!!$ 'y._lo,y._hi,y._b,y._st,y._align);ns=shape([0..n-1]);'//& -!!$ 'v=new map_seq {array=a[ns]};w=new map_seq {array=b[ns]};return v,w}',line) - - call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y))',line) - call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y))',line) - - call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq)=v,w'//& - ' where v,w=overlap(map_seq(x),map_seq(y))',line) - - - call dcl_uproc(parser,'intersect(x:map_seq,y:map_seq) {'//& - 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& - 'var n=0;_intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a);'//& - 'v=new map_seq {array=a[0..n-1]};return v}',line) - - call dcl_uproc(parser,'overlap(x:map_seq,y:map_seq) {'//& - 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& - 'var n=0;_overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a);'//& - 'v=new map_seq {array=a[0..n-1]};return v}',line) - - call dcl_uproc(parser,'overlap(x:map_seq,y:map_seq) {'//& - 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& - 'var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& - 'var n=0;_overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b);'//& - 'ns=shape([0..n-1]);'//& - 'v=new map_seq {array=a[ns]};w=new map_seq {array=b[ns]};return v,w}',line) - - call dcl_uproc(parser,'overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x)',line) - - call dcl_uproc(parser,& - 'expand(t:map_seq,i:range(any_int)) {'//& - 'var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]);var m=0;'//& - '_expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i));'//& - 'v=new map_seq {array=a[0..m-1]};return v}',line) - - call dcl_uproc(parser,'inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array))',line) - call dcl_uproc(parser,'inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y)',line) - call dcl_uproc(parser,'inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y)',line) - call dcl_uproc(parser,'inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y',line) - call dcl_uproc(parser,'in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y))',line) - call dcl_uproc(parser,'#(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y))',line) - - call dcl_uproc(parser,'empty(x:map_seq) {a=array(0,[1..0]);return new map_seq {array=a}}',line) - - ! Grids (tuples of sequences) - call dcl_type(parser,'grid_dim is seq,block_seq,map_seq',line) - call dcl_type(parser,'grid1d(t1:grid_dim) is tuple(t1)',line) - call dcl_type(parser,'grid2d(t1:grid_dim,t2:grid_dim) is tuple(t1,t2)',line) - call dcl_type(parser,'grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is'//& - ' tuple(t1,t2,t3)',line) - call dcl_type(parser,'grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is'//& - ' tuple(t1,t2,t3,t4)',line) - call dcl_type(parser,'grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& - 't5:grid_dim) is'//& - ' tuple(t1,t2,t3,t4,t5)',line) - call dcl_type(parser,'grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& - 't5:grid_dim,t6:grid_dim) is'//& - ' tuple(t1,t2,t3,t4,t5,t6)',line) - call dcl_type(parser,'grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& - 't5:grid_dim,t6:grid_dim,t7:grid_dim) is'//& - ' tuple(t1,t2,t3,t4,t5,t6,t7)',line) - call dcl_type(parser,'grid is tuple(grid_dim)',line) - call dcl_uproc(parser,'_get_elem(x:grid_dim,y:tuple1d)=_get_elem(x,y.1)',line) - call dcl_uproc(parser,'#(x:grid)=shape(map($_shp,x))',line) - call dcl_uproc(parser,'+(x:grid,y:tuple(range_base))=map($+,x,y)',line) - call dcl_uproc(parser,'empty(x:grid)=map($empty,x)',line) - - ! Slices of grids (may have dims that are just an integer and also _ or _() or null) - call dcl_uproc(parser,'_shp(x:stretch_dim)=null',line) - call dcl_uproc(parser,'_shp(x:null)=x',line) - call dcl_uproc(parser,'_size(x:stretch_dim or null)=''1',line) - call dcl_uproc(parser,'_size(x)=size(x)',line) - call dcl_type(parser,'grid_slice_dim:indexable is grid_dim,single_point,null',line) - call dcl_type(parser,'grid_slice:indexable is extent,tuple(grid_slice_dim)',line) - call dcl_proc(parser,'_act(x:single_point)->PM__tinyint',op_miss_arg,0,line,0) - call dcl_uproc(parser,'_act(x)=x',line) - call dcl_uproc(parser,'_sliceit(arg...)=tuple(arg...)',line) - call dcl_uproc(parser,'active_dims(x:grid_slice)=map_apply($_act,$_sliceit,x)',line) - call dcl_uproc(parser,'active_dims(x:single_point)=null',line) - call dcl_uproc(parser,'_ar(x:single_point)=''0',line) - call dcl_uproc(parser,'_ar(x)=''1',line) - call dcl_uproc(parser,'rank(x:grid_slice)=map_reduce($_ar,$+,x)',line) - - call dcl_uproc(parser,'_get_elem(x:grid_slice,arg...:index)'//& - '{t=_tup(arg...);'//& - 'return _ges(head(x),tail(x),head(t),tail(t),''false) }',line) - call dcl_uproc(parser,'_get_elem(x:grid_slice,arg...:subs)'//& - '{t=_tup(arg...);'//& - 'return _ges(head(x),tail(x),head(t),tail(t),''true) }',line) - - call dcl_uproc(parser,'_get_elem(x:null,y)=null',line) - call dcl_uproc(parser,'_spnt(i,y:''true)=i',line) - call dcl_uproc(parser,'_spnt(i,y:''false)=i._t',line) - call dcl_uproc(parser,'_ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) - call dcl_uproc(parser,'_ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => ''false',line) - call dcl_uproc(parser,'_ges(i,x,j,y,t)=prepend(_get_elem(i,j),_ges(head(x),tail(x),head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j,y,t:''true)='//& - 'prepend(_get_elem(i,j),_ges(head(x),tail(x),head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j,y,t:''false)=_ges(head(x),tail(x),head(y),tail(y),t)',line) - call dcl_uproc(parser,'_ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j:stretch_dim,y,t:''true)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j:stretch_dim,y,t:''false)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) - call dcl_uproc(parser,'_ges(i:empty_head,x,j:empty_head,y,t)=null',line) - call dcl_uproc(parser,'_ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => ''false',line) - call dcl_uproc(parser,'_ges(i:null,x,j:empty_head,y,t:''true)=error_type() :test "Rank mismatch" => ''false',line) - call dcl_uproc(parser,'_ges(i:null,x,j:empty_head,y,t:''false)=null',line) - - call dcl_uproc(parser,'size(x:grid_slice)=map_reduce($_size,$*,x)',line) - call dcl_uproc(parser,'#(x:grid_slice)=shape(map($_shp,active_dims(x)))',line) !!! - call dcl_uproc(parser,'dims(x:grid_slice)=map($_size,active_dims(x))',line) - call dcl_uproc(parser,'_arb(x:grid_slice)=map($_arb,x)',line) - call dcl_uproc(parser,'in(x:tuple(range_base),y:grid_slice)='//& - 'map_reduce($in,$and,x,y)',line) - call dcl_uproc(parser,' inc(x:grid_slice,y:grid_slice)='//& - 'map_reduce($inc,$and,x,y)',line) - call dcl_uproc(parser,'#(x:grid,y:tuple(subs_dim))='//& - 'map($#,x,y)',line) - call dcl_proc(parser,'_acthash(x:single_point,y:any)->PM__tinyint',op_miss_arg,0,line,0) - call dcl_uproc(parser,'_acthash(x,y)=x#y',line) - call dcl_uproc(parser,'#(x:grid_slice,y:tuple(subs_dim) or grid_slice)='//& - 'map_apply($_acthash,$_sliceit,x,y)',line) - call dcl_uproc(parser,'convert(x:grid_slice,y:real_num)=map_const($convert,x,y)',line) - call dcl_uproc(parser,'sint(x:grid_slice)=map($sint,x)',line) - call dcl_uproc(parser,'int(x:grid_slice)=map($int,x)',line) - call dcl_uproc(parser,'sreal(x:grid_slice)=map($sreal,x)',line) - call dcl_uproc(parser,'real(x:grid_slice)=map($real,x)',line) - call dcl_uproc(parser,'low(x:grid_slice)=map($low,x)',line) - call dcl_uproc(parser,'high(x:grid_slice)=map($high,x)',line) - call dcl_uproc(parser,'overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y)',line) - call dcl_uproc(parser,'overlap(x:grid_slice,y:grid_slice)=u,v'//& - ' where u,v=map($overlap,x,y)',line) - call dcl_uproc(parser,'intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y)',line) - call dcl_uproc(parser,'intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y))',line) - call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y))',line) - call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y))',line) - call dcl_uproc(parser,'intersect_aligned(x:grid,y:grid)=map($intersect_aligned,x,y)',line) - call dcl_uproc(parser,'expand(x:grid_slice,y:grid)='//& - 'map($expand,x,y)',line) - call dcl_uproc(parser,'contact(x:grid_slice,y:grid)='//& - 'map($contract,x,y)',line) - - call dcl_proc(parser,'gcd(x:int,y:int)->int',op_gcd,0,line,0) - - ! ***************************************************** - ! SHAPES - ! ***************************************************** - - call dcl_type(parser,'extent is tuple(range(int) ),'//& - 'extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d',line) - - call dcl_type(parser,'extent1d is tuple1d_of(range(int))',line) - call dcl_type(parser,'extent2d is tuple2d_of(range(int))',line) - call dcl_type(parser,'extent3d is tuple3d_of(range(int))',line) - call dcl_type(parser,'extent4d is tuple4d_of(range(int))',line) - call dcl_type(parser,'extent5d is tuple5d_of(range(int))',line) - call dcl_type(parser,'extent6d is tuple6d_of(range(int))',line) - call dcl_type(parser,'extent7d is tuple7d_of(range(int))',line) - call dcl_type(parser,'mshape(extent_t:extent) is '//& - 'rec {use _extent:extent_t,_n:int,_o:int}',line) - - call dcl_type(parser,'mshape1d is mshape(extent1d)',line) - call dcl_type(parser,'mshape2d is mshape(extent2d)',line) - call dcl_type(parser,'mshape3d is mshape(extent3d)',line) - call dcl_type(parser,'mshape4d is mshape(extent4d)',line) - call dcl_type(parser,'mshape5d is mshape(extent5d)',line) - call dcl_type(parser,'mshape6d is mshape(extent6d)',line) - call dcl_type(parser,'mshape7d is mshape(extent7d)',line) - - ! Create array, vector and matrix shapes - call dcl_uproc(parser,'_low(x)=low(x)',line) - call dcl_uproc(parser,'_low(x:null)=''0',line) - call dcl_uproc(parser,'_off(x)=-index(dims(x),map($_low,x))',line) - call dcl_uproc(parser,'PM__array(arg...)=shape(map($_extnt,[arg...]))',line) - call dcl_uproc(parser,'_extnt(n:any_int)=0..int(n)-1',line) - call dcl_uproc(parser,'_extnt(n:null)=null',line) - call dcl_uproc(parser,'_extnt(n:range(any_int))=int(n)',line) - - call dcl_uproc(parser,'shape(extent:extent)='//& - 'new mshape {_extent=extent,_n=size(extent),_o=_off(extent)}',line) - - ! Conforming mshapes - call dcl_uproc(parser,'check_conform(x,y) {check_conform(#x,#y)}',line) - call dcl_uproc(parser,'check_conform(x:mshape,y:mshape) {'//& - ' test "Mshapes "++x++" and "++y++" do not conform"=>'//& - 'conform(x,y)}',line) - call dcl_uproc(parser,'_conform(x,y)=size(x)==size(y)',line) - call dcl_uproc(parser,'_conform(x:null,y)=size(y)==''1',line) - call dcl_uproc(parser,'_conform(x,y:null)=''true',line) - call dcl_uproc(parser,'_conform(x:null,y:null)=''true',line) - call dcl_uproc(parser,'conform(x:mshape,y:mshape)='//& - 'map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0'//& - 'check "Values of different ranks cannot conform"=>rank(x)==rank(y)',line) - - ! Local size of a mshape - call dcl_uproc(parser,'_local_size(x:mshape)=size(x._extent)',line) - - ! Extent of a mshape - call dcl_uproc(parser,'extent(x:shape)=x._extent',line) - - ! Dimensions of a mshape - call dcl_uproc(parser,'dims(x:mshape)=map($size,x._extent)',line) - - ! Size from dimensions - call dcl_uproc(parser,'size(x:tuple(int))=reduce($*,x)',line) - - ! Empty mshape - call dcl_uproc(parser,'_empty(x)=1..0',line) - call dcl_uproc(parser,'empty(x:extent)=map($_empty,x)',line) - - ! ***************************************************** - ! INDEXING AND SLICING - ! ***************************************************** - - ! Generic types supporting indexing and mapping - call dcl_type(parser,'indexable is grid_slice,grid,seq,array,...',line) - call dcl_uproc(parser,'[](x:indexable,arg...)'//& - '{y=_tup(arg...);check_contains(#x,y);return _get_elem(x,y)}',line) - - ! Index type - call dcl_type(parser,'index is any_int,tuple(any_int)',line) - - ! Slice and subscript types - call dcl_type(parser,'range_below(x) is rec {_t:x}',line) - call dcl_type(parser,'range_above(x) is rec {_t:x}',line) - call dcl_type(parser,& - 'strided_range_below(x) is rec {_t:x,_st:x}',line) - call dcl_type(parser,& - 'strided_range_above(x) is rec {_t:x,_st:x}',line) - call dcl_type(parser,'stride(x) is rec {_st:x}',line) - call dcl_type(parser,'slice_dim is'//& - ' range(any_int),strided_range(any_int),range_above(any_int),'//& - ' range_below(any_int),strided_range_above(any_int),strided_range_below(any_int),'//& - ' stride(any_int),null,stretch_dim',& - line) - call dcl_type(parser,'slice is slice_dim,tuple(slice_dim)'& - ,line) - call dcl_type(parser,'subs_dim is slice_dim,int',line) - call dcl_type(parser,'subs is index,slice,subs_dim,tuple(subs_dim)',line) - - - ! Partial ranges/sequences mainly used in subscripts - call dcl_uproc(parser,'..._(x)=new range_below {_t=x}',line) - call dcl_uproc(parser,'_...(x)=new range_above {_t=x}',line) - call dcl_uproc(parser,'by(x:range_base)=new stride {_st=x}',line) - call dcl_uproc(parser,'by(x:range_above(),y)='//& - 'new strided_range_above {_t=x._t,_st=convert(y,x._t)}',line) - call dcl_uproc(parser,'by(x:range_below(),y)='//& - 'new strided_range_below {_t=x._t,_st=convert(y,x._t)}',line) - call dcl_uproc(parser,'string(x:range_above)=x._t++"..."',line) - call dcl_uproc(parser,'string(x:range_below)="..."++x._t',line) - call dcl_uproc(parser,'string(x:strided_range_above)=x._t++"... by"++x._st',line) - call dcl_uproc(parser,'string(x:strided_range_below)="..."++x._t++"by "++x._st',line) - call dcl_uproc(parser,'string(x:stride)="by "++x._st',line) - call dcl_uproc(parser,'low(x:range_above)=x._t',line) - call dcl_uproc(parser,'low(x:strided_range_above)=x._t',line) - call dcl_uproc(parser,'high(x:range_below)=x._t',line) - call dcl_uproc(parser,'high(x:strided_range_below)=x._t',line) - call dcl_uproc(parser,'step(x:range_above or range_below)=''1',line) - call dcl_uproc(parser,'step(x:strided_range_above or strided_range_below)=x._st',line) - call dcl_uproc(parser,'width(x:strided_range_above or strided_range_below or '//& - 'range_above or range_below)=''1',line) - - ! Stretch dimension in subscript - call dcl_type(parser,'stretch_dim is unique{PM__strdim}',line) - call dcl_uproc(parser,'string(x:stretch_dim)="_"',line) - call dcl_uproc(parser,'size(x:stretch_dim)=''1',line) - call dcl_uproc(parser,'expand(x:stretch_dim,y:grid)=x',line) - call dcl_uproc(parser,'contract(x:stretch_dim,y:grid)=x',line) - call dcl_uproc(parser,'in(x:stretch_dim,y)=''true',line) - call dcl_uproc(parser,' inc(x:stretch_dim,y)=''true',line) - call dcl_uproc(parser,'convert(x:stretch_dim,y:range_base)=x',line) - call dcl_uproc(parser,'#(x:stretch_dim,y:index)=''0',line) - call dcl_uproc(parser,'#(x:stretch_dim,y:grid_slice_dim)=''0..''0',line) - call dcl_uproc(parser,'intersect(x:stretch_dim,y:grid_slice_dim)=y',line) - call dcl_uproc(parser,'intersect(x:grid_slice_dim,y:stretch_dim)=x',line) - call dcl_uproc(parser,'intersect(x:stretch_dim,y:stretch_dim)=x',line) - call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:stretch_dim)=#x',line) - call dcl_uproc(parser,'overlap(x:stretch_dim,y:grid_slice_dim)=''0..''0',line) - call dcl_uproc(parser,'overlap(x:stretch_dim,y:stretch_dim)=''0..''0',line) - - ! Check subscript is in range - call dcl_uproc(parser,'check_contains(a:extent,arg...) '//& - '{test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...)}',line) - call dcl_uproc(parser,'check_contains(a:mshape,arg...) {check_contains(a._extent,arg...)}',line) - call dcl_uproc(parser,'check_contains(a,arg...) {check_contains(#a,arg...)}',line) - call dcl_uproc(parser,'check_contains(a:dshape,arg...) {check_contains(a._mshape._extent,arg...)}',line) - call dcl_uproc(parser,'_contains(x:null,y)=''true',line) - call dcl_uproc(parser,'_contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y)',line) - call dcl_uproc(parser,'_contains(x:range(int),y:range(any_int) or seq(any_int))='//& - '_contains(x,y._lo) and _contains(x,y._hi) or y._lo>y._hi',line) - call dcl_uproc(parser,'_contains(x:range(int),y:range_below(any_int) or '//& - 'strided_range_below(any_int) or range_above(any_int) or '//& - 'strided_range_above(any_int))=_contains(x,y._t)',line) - call dcl_uproc(parser,'_contains(x:range(int),y:stride(any_int))=''true',line) - call dcl_uproc(parser,'_contains(x:range(int),y:null)=''true',line) - call dcl_uproc(parser,'contains(x:mshape1d,y:subs_dim)='//& - '_contains(x.1,y)',line) - call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim))='//& - 'map_reduce($_contains,$and,x,y)',line) - call dcl_proc(parser,'_rgd(x:stretch_dim)->PM__tinyint',op_miss_arg,0,line,0) - call dcl_uproc(parser,'_rgd(x)=x',line) - call dcl_uproc(parser,'_rigid_dims(x:grid_slice or tuple(subs_dim))='//& - 'map_apply($_rgd,$_sliceit,x)',line) - call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim)'//& - ' and contains(stretch_dim))=contains(x,_rigid_dims(y))',line) - call dcl_uproc(parser,'contains(x:extent,y,arg...)=contains(x,[y,arg...])',line) - - ! Complete a subscript using a base mshape - call dcl_uproc(parser,& - 'fill_in(x:null,y)=y :test "Cannot use incomplete subscript on null dimension" => ''false',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int)=single_point(int(y))',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:range(any_int))=int(y)',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:strided_range(any_int))=int(y)',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:range_below(any_int))=x._lo..int(y._t)',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:range_above(any_int))=int(y._t)..x._hi',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_below(any_int))=lo..int(y._t) by y._st'//& - ' where lo=y._t-(y._t-x._lo)/y._st*y._st',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_above(any_int))=int(y._t)..x._hi by y._st',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:stride(any_int))=x by int(y._st)',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:null)=x',line) - call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim))=map($fill_in,x,y)',line) - call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim))='//& - '_fill_in(x,head(y),tail(y))',line) - call dcl_uproc(parser,'_fill_in(x,y,z)=prepend(fill_in(x.1,y),'//& - '_fill_in(tail(x),head(z),tail(z)))',line) - call dcl_uproc(parser,'_fill_in(x,y:stretch_dim,z)='//& - 'prepend(null,_fill_in(x,head(z),tail(z)))',line) - call dcl_uproc(parser,'_fill_in(x:null,y:empty_head,z)=null',line) - call dcl_uproc(parser,& - '_fill_in(x:empty_head,y:stretch_dim,z)=prepend(null,_fill_in(x,head(z),tail(z)))',line) - call dcl_uproc(parser,'_fill_in(x:empty_head,y,z)=error_type() :test "Rank mismatch in slice" => ''false',line) - - ! ******************************************************* - ! SUBSCRIPT INTERSECTION AND ALIASING - ! ******************************************************* - - ! Test for intersection between two subscripts - call dcl_uproc(parser,'intersects(x:null,y:subs_dim)=''true',line) - call dcl_uproc(parser,'intersects(x:subs_dim,y:null)=''true',line) - call dcl_uproc(parser,'intersects(x:null,y:null)=''true',line) - call dcl_uproc(parser,'intersects(x:range(any_int),y:range(any_int))='//& - 'not(x._hiy._hi)',line) - call dcl_uproc(parser,'intersects(x:seq(any_int),y:seq(any_int))=size(intersect(x,y))>0',line) - call dcl_uproc(parser,'intersects(x:range(any_int),'//& - 'y:range_above(any_int) or strided_range_above(any_int))=x._hi>=y._t',line) - call dcl_uproc(parser,'intersects(x:range_above(any_int) or strided_range_above(any_int),'//& - 'y:range(any_int))=y._hi>=x._t',line) - call dcl_uproc(parser,'intersects(x:range(any_int),'//& - 'y:range_below(any_int) or strided_range_below(any_int))=x._lo<=y._t',line) - call dcl_uproc(parser,'intersects(x:range_below(any_int) or strided_range_below(any_int),'//& - 'y:range(any_int))=y._lo<=x._t',line) - call dcl_uproc(parser,'intersects(x:strided_range(any_int),'//& - 'y:range_above(any_int) or strided_range_above(any_int))='//& - 'intersects(y._t..x._hi by step(y),x)',line) - call dcl_uproc(parser,'intersects(y:range_above(any_int) or strided_range_above(any_int),'//& - 'x:strided_range(any_int))=intersects(y._t..x._hi by step(y),x)',line) - call dcl_uproc(parser,'intersects(x:strided_range(any_int),'//& - 'y:range_below(any_int) or strided_range_below(any_int))='//& - 'intersects(x,y._t..x._lo by -step(y))',line) - call dcl_uproc(parser,'intersects(y:range_below(any_int) or strided_range_below(any_int),'//& - 'x:strided_range(any_int))='//& - 'intersects(x,y._t..x._lo by -step(y))',line) - call dcl_uproc(parser,'intersects(x:range_below(any_int) or strided_range_below(any_int),'//& - 'y:range_above(any_int) or strided_range_above(any_int))=x._t>=y._t',line) - call dcl_uproc(parser,'intersects(x:range_above(any_int) or strided_range_above(any_int),'//& - 'y:range_below(any_int) or strided_range_below(any_int))=y._t>=x._t',line) - call dcl_uproc(parser,'intersects(x:range_above(any_int) or strided_range_above(any_int),'//& - 'y:range_above(any_int) or strided_range_above(any_int))=''true',line) - call dcl_uproc(parser,'intersects(x:range_below(any_int) or strided_range_below(any_int),'//& - 'y:range_below(any_int) or strided_range_below(any_int))=''true',line) - call dcl_uproc(parser,'intersects(x:strided_range_below(any_int),'//& - 'y:strided_range_above(any_int))='//& - 'size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0',line) - call dcl_uproc(parser,'intersects(y:strided_range_above(any_int),'//& - 'x:strided_range_below(any_int))='//& - 'size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0',line) - call dcl_uproc(parser,'intersects(x:strided_range_above(any_int),'//& - 'y:strided_range_above(any_int))=abs(x._t-y._t) mod gcd(int(x._st),int(y._st))==0',& - line) - call dcl_uproc(parser,'intersects(x:strided_range_below(any_int),'//& - 'y:strided_range_below(any_int))='//& - 'abs(x._t-y._t) mod gcd(abs(int(x._st)),abs(int(y._st)))==0',& - line) - call dcl_uproc(parser,'intersects(x:stride(any_int),y:subs_dim)=''true',line) - call dcl_uproc(parser,'intersects(x:subs_dim,y:stride(any_int))=''true',line) - call dcl_uproc(parser,'intersects(x:stride(any_int),y:stride(any_int))=''true',line) - - call dcl_uproc(parser,'intersects(x:seq,y:int)=y in x',line) - call dcl_uproc(parser,'intersects(x:int,y:seq)=x in y',line) - call dcl_uproc(parser,'intersects(x:int,y:int)=x==y',line) - - call dcl_uproc(parser,'intersects(x:int,y:range_above(any_int))=x>=y._t',line) - call dcl_uproc(parser,'intersects(x:int,y:range_below(any_int))=x<=y._t',line) - call dcl_uproc(parser,'intersects(x:int,y:strided_range_above(any_int))='//& - 'x>=y._t and (x-y._t) mod y._st==0',line) - call dcl_uproc(parser,'intersects(x:int,y:strided_range_below(any_int))='//& - 'x<=y._t and (y._t-x) mod y._st==0',line) - call dcl_uproc(parser,'intersects(y:range_above(any_int),x:int)=x>=y._t',line) - call dcl_uproc(parser,'intersects(y:range_below(any_int),x:int)=x<=y._t',line) - call dcl_uproc(parser,'intersects(y:strided_range_above(any_int),x:int)='//& - 'x>=y._t and (x-y._t) mod y._st==0',line) - call dcl_uproc(parser,'intersects(y:strided_range_below(any_int),x:int)='//& - 'x<=y._t and (y._t-x) mod y._st==0',line) - call dcl_uproc(parser,'_intersects(x,y,z:''true)=map_reduce($intersects,$and,x,y)',line) - call dcl_uproc(parser,'_intersects(x,y,z:''false)=''false',line) - call dcl_uproc(parser,'intersects(x:tuple(subs_dim except stretch_dim),'//& - 'y:tuple(subs_dim except stretch_dim))=_intersects(x,y,rank(x)==rank(y))',line) - call dcl_uproc(parser,'intersects(x:tuple(subs_dim),y:tuple(subs_dim))='//& - '_intersects(rx,ry,rank(rx)==rank(ry))'//& - 'where rx=_rigid_dims(x),ry=_rigid_dims(y)',line) - call dcl_uproc(parser,'intersects(x:tuple(subs_dim),y:null)=''true',line) - call dcl_uproc(parser,'intersects(x:null,y:tuple(subs_dim))=''true',line) - - call dcl_uproc(parser,'_intersects(x:subs,y:subs)=intersects(x,y)',line) - call dcl_uproc(parser,'_intersects(x,y)=''false',line) - - ! Alias checking - call dcl_uproc(parser,'PM__check_alias(i,j,x,y) {'//& - 'test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) }',line) - call dcl_uproc(parser,'PM__check_alias(i,j,x,y,arg...) {'//& - 'if _intersects(x,y):PM__check_alias(i,j,arg...)}',line) - - ! Combining subscripts - call dcl_uproc(parser,'PM__cmbidx(x,y)=_cmb(x,y)',line) - call dcl_uproc(parser,'PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...)',line) - call dcl_type(parser,'_cmb_error is unique',line) - call dcl_uproc(parser,'_cmb(x,y)=_cmb_error',line) - call dcl_uproc(parser,'_cmb(x:subs except index,y:subs)=_cmb1(x,y)',line) - call dcl_uproc(parser,'_cmb1(x,y)=_cmb_error',line) - call dcl_uproc(parser,'_cmb1(x:subs_dim,y:subs_dim)=x[y]',line) - call dcl_uproc(parser,'_cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y))',line) - call dcl_uproc(parser,'_cmb2(x,y,z:''true)=x[y]',line) - call dcl_uproc(parser,'_cmb2(x,y,z:''false)=_cmb_error',line) - - ! ******************************************************* - ! ITERATION - SEQUENTIAL AND CONCURRENT - ! ******************************************************* - - ! Iteration over mshape - - ! - first element - call dcl_uproc(parser,'PM__first(d:int)=0,null,d>0',line) - call dcl_uproc(parser,'PM__first(d:tuple1d)='//& - 'i,s,e where i,s,e=PM__first(d.1)',line) - call dcl_uproc(parser,'PM__first(d:tuple2d)='//& - '[j1,j2],[s1,s2],e1 and e2'//& - ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2)',line) - call dcl_uproc(parser,'PM__first(d:tuple3d)='//& - '[j1,j2,j3],[s1,s2,s3],e1 and e2 and e3'//& - ' where j1,s1,e1=PM__first(d.1),'//& - 'j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3)',& - line) - call dcl_uproc(parser,'PM__first(d:tuple4d)='//& - '[j1,j2,j3,j4],[s1,s2,s3,s4],'//& - 'e1 and e2 and e3 and e4'//& - ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),'//& - 'j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4)',line) - call dcl_uproc(parser,'PM__first(d:tuple5d)=[j1,j2,j3,j4,j5],'//& - ' [s1,s2,s3,s4,s5],'//& - 'e1 and e2 and e3 and e4 and e5'//& - ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,'//& - 'e3=PM__first(d.3),j4,s4,e4=PM__first(d.4),'//& - ' j5,s5,e5=PM__first(d.5)',line) - call dcl_uproc(parser,'PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],'//& - '[s1,s2,s3,s4,s5,s6],'//& - 'e1 and e2 and e3 and e4 and e5 and e6'//& - ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),'//& - 'j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4),'//& - ' j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6)',line) - call dcl_uproc(parser,'PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],'//& - '[s1,s2,s3,s4,s5,s6,s7],'//& - 'e1 and e2 and e3 and e4 and e5 and e6 and e7'//& - ' where j1,s1,e1=PM__first(d.1),j2,s2,'//& - 'e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),'//& - 'j4,s4,e4=PM__first(d.4),'//& - ' j5,s5,e5=PM__first(d.5),'//& - 'j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7)',line) - - ! - subsequent elements - call dcl_uproc(parser,'PM__next(d:int,g,i)=ii,null,iiint',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_doloop(int,int)->int,int',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_doloop(int,int,int)->int,int,int',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_doloop(int,int,int,int)->int,int,int,int',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_doloop(int,int,int,int,int)->int,int,int,int,int',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_doloop(int,int,int,int,int,int)->int,int,int,int,int,int',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_doloop(int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int,int',& - op_do_loop,0,line,& - proc_is_generator) - call dcl_uproc(parser,& - '_elts(x:int)=i '//& - 'where i=_doloop(x)',line) - call dcl_uproc(parser,& - '_elts(x:tuple1d)=[i] where i=_elts(x.1)',line) - call dcl_uproc(parser,& - '_elts(x:tuple2d)=[i,j] where '//& - 'i,j=_doloop(x.1,x.2)',line) - call dcl_uproc(parser,& - '_elts(x:tuple3d)=[i,j,k] where '//& - 'i,j,k=_doloop(x.2,x.2,x.3)',line) - call dcl_uproc(parser,& - '_elts(x:tuple4d)=[i,j,k,l] where '//& - 'i,j,k,l=_doloop(x.1,x.2,x.3,x.4)',line) - call dcl_uproc(parser,& - '_elts(x:tuple5d)=[i,j,k,l,m] where '//& - 'i,j,k,l,m=_doloop(x.1,x.2,x.3,x.4,x.5)',line) - call dcl_uproc(parser,& - '_elts(x:tuple6d)=[i,j,k,l,m,n] where '//& - 'i,j,k,l,m,n=_doloop(x.1,x.2,x.3,x.4,x.5,x.6)',line) - call dcl_uproc(parser,& - '_elts(x:tuple7d)=[i,j,k,l,m,n,o] where '//& - 'i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7)',line) - - call dcl_proc(parser,& - '_blockedloop(any)->int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_blockedloop(any)->int,int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_blockedloop(any)->int,int,int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int,int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int,int,int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_blockedloop(any)->'//& - 'int,int,int,int,int,int,int',& - op_blocked_loop,0,line,& - proc_is_generator) - call dcl_uproc(parser,& - '_belts(x,y:shape1d)=[i] where '//& - 'i=_blockedloop(PM__do_over(x,y))',line) - call dcl_uproc(parser,& - '_belts(x,y:shape2d)=[i,j] where '//& - 'i,j=_blockedloop(PM__do_over(x,y))',line) - call dcl_uproc(parser,& - '_belts(x,y:shape3d)=[i,j,k] where '//& - 'i,j,k=_blockedloop(PM__do_over(x,y))',line) - call dcl_uproc(parser,& - '_belts(x,y:shape4d)=[i,j,k,l] where '//& - 'i,j,k,l=_blockedloop(PM__do_over(x,y))',line) - call dcl_uproc(parser,& - '_belts(x,y:shape5d)=[i,j,k,l,m] where '//& - 'i,j,k,l,m=_blockedloop(PM__do_over(x,y))',line) - call dcl_uproc(parser,& - '_belts(x,y:shape6d)=[i,j,k,l,m,n] where '//& - 'i,j,k,l,m,n=_blockedloop(PM__do_over(x,y))',line) - call dcl_uproc(parser,& - '_belts(x,y:shape7d)=[i,j,k,l,m,n,o] where '//& - 'i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y))',line) - else - - call dcl_uproc(parser,'PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n)',line) - call dcl_uproc(parser,'PM__generate(x:mshape,n,s)=_elts(dims(x),1,n)',line) - - call dcl_proc(parser,& - '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->int',& - op_iota,0,line,& - proc_is_generator) - call dcl_proc(parser,& - '_iota(siz:int,start:int,finish:int,incr:int,'//& - 'first:int,trunc:int,totsiz:int)->int',& - op_iota,0,line,& - proc_is_generator) - call dcl_uproc(parser,'_n(x:int)=x',line) - call dcl_uproc(parser,& - '_elts(x:int,siz,tot)=_iota(siz,0,x-1,1,tot)',line) - call dcl_uproc(parser,& - '_elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot))',line) - call dcl_uproc(parser,& - '_elts(x:tuple2d,siz,tot)='//& - 'tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) )',line) - call dcl_uproc(parser,& - '_elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),'//& - '_elts(x.2,s1,tot),'//& - '_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1)',line) - call dcl_uproc(parser,& - '_elts(x:tuple4d,siz,tot)='//& - 'tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),'//& - '_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) '//& - 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) - call dcl_uproc(parser,& - '_elts(x:tuple5d,siz,tot)='//& - 'tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),'//& - '_elts(x.3,s2,tot),_elts(x.4,s3,tot),'//& - '_elts(x.5,s3*_n(x.4), tot)) '//& - 'where s3=s2*_n(x.3) where s2=s1*_n(x.2) '//& - 'where s1=siz*_n(x.1)',& - line) - call dcl_uproc(parser,& - '_elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),'//& - '_elts(x.2,s1,tot),'//& - '_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),'//& - '_elts(x.6,s4*_n(x.5), tot)) '//& - 'where s4=s3*_n(x.4) where s3=s2*_n(x.3) '//& - 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) - call dcl_uproc(parser,& - '_elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),'//& - '_elts(x.2,s1,tot),'//& - '_elts(x.3,s2,tot),_elts(x.4,s3,tot),'//& - '_elts(x.5,s4,tot),_elts(x.6,s5,tot),'//& - '_elts(x.7,s5*_n(x.6), tot)) '//& - 'where s5=s4*_n(x.5) where s4=s3*_n(x.4) '//& - 'where s3=s2*_n(x.3) '//& - 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) - endif - - call dcl_proc(parser,& - '_indices(any)->int',op_indices,0,line,0) - - ! ************************************** - ! ARRAYS - ! ************************************** - - ! Array types - call dcl_type(parser,& - 'array(e,d:shape) is varray(e,d),farray(e,d)',line) - call dcl_type(parser,'varray(e,d:shape) is'//& - ' e^var d,array_template(e,d,''true)',line) - call dcl_type(parser,'farray(e,d:shape) is'//& - ' e^const d,e^invar d,e^fix d,array_template(e,d,''false)',line) - call dcl_type(parser,'farray(e,d:mshape) is ...,'//& - 'array_slice(e^const any),array_slice(e^var any),'//& - 'array_slice(e^invar any),array_slice(e^fix any)',line) - - ! Array operations - call dcl_uproc(parser,'_arb(x:any^mshape)='//& - '_get_aelem(x,0)',line) - call dcl_proc(parser,'size(x:any^mshape)->int',op_get_size,0,line,0) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->PM__dim x,y',& - op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->PM__vdim x,y',& - op_var_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& - op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& - merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) - call dcl_proc(parser,& - '_redim(x:any^any,y:any)->over x,y',& - op_redim,0,line,proc_needs_type) - call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->PM__dim x,y',& - op_array_noinit,0,line,proc_needs_type) - - call dcl_uproc(parser,'#%(x:invar any^any)=_array_shape(x <>)',line) - call dcl_uproc(parser,'#%(x)=_get_shape(x)',line) - call dcl_uproc(parser,'_get_shape(x)=#x',line) - call dcl_uproc(parser,'#(x:any^any)=_array_shape(x)',line) - call dcl_proc(parser,'_array_shape(x:any^any)->#x',op_get_dom,0,line,0) - call dcl_uproc(parser,'dims(x:any^mshape)=dims(#x)',line) - call dcl_proc(parser,'PM__extractelm(x:any^any)->%x',& - op_extractelm,0,line,0) - - call dcl_uproc(parser,'_get_elem(a:any^mshape,t:index)='//& - '_get_aelem(a,index(#(a),t))',line) - call dcl_uproc(parser,'_set_elem(&a:any^mshape,v,t:index)'//& - '{ PM__setaelem(&a,index(#(a),t),v) }',line) - call dcl_uproc(parser,'_make_subref(a:any^mshape,t:index)='//& - '_make_subref(a,index(#(a),t))',line) - call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->%a',& - op_make_rf,0,line,0) - - call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->%x',& - op_array_get_elem,0,line,0) - call dcl_proc(parser,'PM__setaelem(&x:any^any,y:int,z:any)',& - op_array_set_elem,0,line,0) - - ! Linear index of tuple mshape (zero base,unit stride) - call dcl_uproc(parser,'_indx(g:null,s)=''0',line) - call dcl_uproc(parser,'_indx(g:range(int),s)=int(s)',line) - call dcl_uproc(parser,'_indx(g:any_int,s)=int(s)',line) - call dcl_uproc(parser,'_sz(x:null)=''1',line) - call dcl_uproc(parser,'_sz(x:int)=x',line) - call dcl_uproc(parser,'_sz(x:range(int))=x._n',line) - call dcl_uproc(parser,'_offset(x:mshape)=x._o',line) - call dcl_uproc(parser,'_offset(x)=''0',line) - call dcl_uproc(parser,'index(g:mshape1d or tuple1d_of(int),s:any_int)=int(_indx(g.1,s))+_offset(g)',line) - call dcl_uproc(parser,'index(g:mshape1d or tuple1d_of(int),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g)',line) - call dcl_uproc(parser,'index(g:mshape2d or tuple2d_of(int),s:tuple2d_of(any_int))='//& - 'int(_indx(g.1,s.1)+_sz(g.1)*'//& - '_indx(g.2,s.2))+_offset(g)',line) - call dcl_uproc(parser,'index(g:mshape3d or tuple3d_of(int),s:tuple3d_of(any_int))='//& - 'int(_indx(g.1,s.1)+_sz(g.1)*'//& - '(_indx(g.2,s.2)+_sz(g.2)*'//& - '_indx(g.3,s.3)))+_offset(g)',line) - call dcl_uproc(parser,& - 'index(g:mshape4d or tuple4d_of(int),s:tuple4d_of(any_int))='//& - ' int(_indx(g.1,s.1)+_sz(g.1)*'//& - ' (_indx(g.2,s.2)+_sz(g.2)*'//& - ' (_indx(g.3,s.3)+_sz(g.3)*'//& - ' _indx(g.4,s.4))))+_offset(g)',line) - call dcl_uproc(parser,& - 'index(g:mshape5d or tuple5d_of(int),s:tuple5d_of(any_int))='//& - ' int(_indx(g.1,s.1)+_sz(g.1)*'//& - ' (_indx(g.2,s.2)+_sz(g.2)*'//& - ' (_indx(g.3,s.3)+_sz(g.3)*'//& - ' (_indx(g.4,s.4)+_sz(g.4)*'//& - ' _indx(g.5,s.5)))))+_offset(g)',line) - call dcl_uproc(parser,& - 'index(g:mshape6d or tuple6d_of(int),s:tuple6d_of(any_int))='//& - ' int(_indx(g.1,s.1)+_sz(g.1)*'//& - ' (_indx(g.2,s.2)+_sz(g.2)*'//& - ' (_indx(g.3,s.3)+_sz(g.3)*'//& - ' (_indx(g.4,s.4)+_sz(g.4)*'//& - ' (_indx(g.5,s.5)+_sz(g.5)*'//& - ' _indx(g.6,s.6))))))+_offset(g)',line) - call dcl_uproc(parser,& - 'index(g:mshape7d or tuple7d_of(int),s:tuple7d_of(any_int))='//& - ' int(_indx(g.1,s.1)+_sz(g.1)*'//& - ' (_indx(g.2,s.2)+_sz(g.2)*'//& - ' (_indx(g.3,s.3)+_sz(g.3)*'//& - ' (_indx(g.4,s.4)+_sz(g.4)*'//& - ' (_indx(g.5,s.5)+_sz(g.5)*'//& - ' (_indx(g.6,s.6)+_sz(g.6)*'//& - ' (_indx(g.7,s.7))))))))+_offset(g)',line) - - call dcl_uproc(parser,'index2point(i:int,s:range(int))=[i+s._lo]',line) - call dcl_uproc(parser,'index2point(i:int,s:int)=[i]',line) - call dcl_uproc(parser,'index2point(i:int,s:tuple1d_of(int))=[i]',line) - call dcl_uproc(parser,& - 'index2point(i:int,s:tuple2d_of(int))='//& - '[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1)',line) - call dcl_uproc(parser,'index2point(i:int,s:tuple3d_of(int))='//& - '[i1,i2,i3] where i1=i-j2*_sz(s.1) '//& - 'where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) - call dcl_uproc(parser,& - 'index2point(i:int,s:tuple4d_of(int))='//& - '[i1,i2,i3,i4]'//& - ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3)'//& - ' where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) - call dcl_uproc(parser,& - 'index2point(i:int,s:tuple5d_of(int))='//& - '[i1,i2,i3,i4,i5]'//& - ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& - ' where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) '//& - ' where i5=j4/_sz(s.4)'//& - ' where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) - call dcl_uproc(parser,'index2point(i:int,s:tuple6d_of(int))='//& - '[i1,i2,i3,i4,i5,i6]'//& - ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& - ' where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) '//& - ' where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5)'//& - ' where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) - call dcl_uproc(parser,'index2point(i:int,s:tuple7d_of(int))='//& - '[i1,i2,i3,i4,i5,i6,i7]'//& - ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& - ' where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) '//& - ' where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6)'//& - ' where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3)'//& - ' where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) - - ! ***************************************** - ! ARRAY TEMPLATES - ! ***************************************** - - ! Array templates - call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool,i:fix bool,f:fix bool)'//& - ' is rec {_a:a,_d:d,_s:int,_v:v,_i:i=''false,_f:f=''false}',line) - call dcl_uproc(parser,& - 'array(a:any,s:dshape)='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) - call dcl_uproc(parser,& - 'array(a:any,s:mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) - call dcl_uproc(parser,& - 'array(a:any,s:fix mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_f=''true}',line) - call dcl_uproc(parser,& - 'array(a:any,s:tuple(range(any_int)))=array(a,shape(s))',line) - call dcl_uproc(parser,'dim%(a,d)=array(a,d)',line) - call dcl_uproc(parser,'dim%(a,s:invar mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}',line) - call dcl_uproc(parser,'dim%(a,sh:invar tuple(range(any_int)))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}'//& - 'where s=shape(sh)',line) - - call dcl_uproc(parser,& - 'varray(a:any,s:mshape or dshape)='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''true}',line) - call dcl_uproc(parser,& - 'varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s))',line) - call dcl_uproc(parser,'_zero(x)=0',line) - call dcl_uproc(parser,& - 'varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s)))',line) - - ! Treat a template as if it were an array - call dcl_uproc(parser,'_arb(a:array_template)=a._a',line) - call dcl_uproc(parser,'#(a:array_template(,mshape,))=a._d',line) - call dcl_uproc(parser,'dims(a:array_template(,mshape,))=dims(a._d)',line) - call dcl_uproc(parser,'size(a:array_template)=a._s',line) - call dcl_uproc(parser,'redim(a:array_template,d:mshape)='//& - ' new array_template { _a=a,_d=d,_s=size(d),_v=a._v}'//& - ' check "New dshape does not have same size in redim"=>'//& - ' size(d)==a._s',line) - call dcl_uproc(parser,'_get_elem(a:array_template,arg...:subs)=a._a',line) - - ! Array creation from template - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,,''true))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''false)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,''true,''false))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''true)',line) - - call dcl_uproc(parser,'PM__do_dim(a:any,d:mshape)='//& - '_array(a,d,size(d),''false)',& - line) - - - !***************************************** - ! MATRIX AND VECTOR - ! ***************************************** - - - - call dcl_type(parser,'matrix_element is num,bool,...',line) - call dcl_type(parser,'_matrix(t) is struct{use array:t}',line) - call dcl_type(parser,'matrix(t:matrix_element) is _matrix(array(t,shape2d))',line) - call dcl_type(parser,'vector(t:matrix_element) is _matrix(array(t,shape1d))',line) - call dcl_type(parser,'matrix_template(t:matrix_element) is _matrix(array_template(t,shape2d))',line) - call dcl_type(parser,'vector_template(t:matrix_element) is _matrix(array_template(t,shape1d))',line) - call dcl_uproc(parser,'PM__matrix(x)=new _matrix{array=x}',line) - call dcl_uproc(parser,'vector(x:matrix_element,n:shape1d or extent1d)='//& - 'PM__matrix(array(x,n))',line) - call dcl_uproc(parser,'vvector(x:matrix_element,n:shape1d or extent1d)='//& - 'PM__matrix(varray(x,n))',line) - call dcl_uproc(parser,'dvector(x:matrix_element,n:shape1d or extent1d)='//& - 'PM__matrix(array(x,n,BLOCK_CYCLIC(32)))',line) - call dcl_uproc(parser,'dvvector(x:matrix_element,n:shape1d or extent1d)='//& - 'PM__matrix(varray(x,n,BLOCK_CYCLIC(32)))',line) - call dcl_uproc(parser,'vector(x:matrix_element,n:shape1d or extent1d,'//& - 'distr:distr_template,key...)='//& - 'PM__matrix(array(x,n,distr,key...))',line) - call dcl_uproc(parser,'vvector(x:matrix_element,n:shape1d or extent1d,'//& - 'distr:distr_template,key...)='//& - 'PM__matrix(varray(x,n,key...))',line) - call dcl_uproc(parser,'matrix(x:matrix_element,n:shape2d or extent2d)='//& - 'PM__matrix(array(x,n))',line) - call dcl_uproc(parser,'vmatrix(x:matrix_element,n:shape2d or extent2d)='//& - 'PM__matrix(varray(x,n))',line) - call dcl_uproc(parser,'dmatrix(x:matrix_element,n:shape2d or extent2d)='//& - 'PM__matrix(array(x,n,BLOCK_CYCLIC(32)))',line) - call dcl_uproc(parser,'dvmatrix(x:matrix_element,n:shape2d or extent2d)='//& - 'PM__matrix(varray(x,n,BLOCK_CYCLIC(32)))',line) - call dcl_uproc(parser,'matrix(x:matrix_element,n:shape2d or extent2d,'//& - 'distr:distr_template,key...)='//& - 'PM__matrix(array(x,n,distr,key...))',line) - call dcl_uproc(parser,'vmatrix(x:matrix_element,n:shape2d or extent2d,'//& - 'distr:distr_template,key...)='//& - 'PM__matrix(varray(x,n,key...))',line) - - call dcl_uproc(parser,'matrix_element_zero(x:num)=convert(0,x)',line) - call dcl_uproc(parser,'matrix_element_balance(x:num,y:num)=xx,yy where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,'matrix_element_add(x:num,y:num)=x+y',line) - call dcl_uproc(parser,'matrix_element_subtract(x:num,y:num)=x-y',line) - call dcl_uproc(parser,'matrix_element_multiply(x:num,y:num)=x*y',line) - call dcl_uproc(parser,'matrix_element_zero(x:bool)=false',line) - call dcl_uproc(parser,'matrix_element_balance(x:bool,y:bool)=x,y',line) - call dcl_uproc(parser,'matrix_element_add(x:bool,y:bool)=x or y',line) - call dcl_uproc(parser,'matrix_element_multiply(x:bool,y:bool)=x and y',line) - - call dcl_uproc(parser,'+(x:matrix,y:matrix) {'//& - 'check_conform(x.array,y.array);'//& - 'test "Cannot add zero size matrices"=>size(x)>0;'//& - 'var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& - 'for xx in x.array, yy in y.array, zz in z.array:zz:=matrix_element_add(xx,yy) '//& - 'return z }',line) - - call dcl_uproc(parser,'-(x:matrix,y:matrix) {'//& - 'check_conform(x.array,y.array);'//& - 'test "Cannot add zero size matrices"=>size(x)>0;'//& - 'var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& - 'for xx in x.array, yy in y.array, zz in z.array:zz:=matrix_element_subtract(xx,yy) '//& - 'return z }',line) - - call dcl_uproc(parser,'*(x:matrix,y:matrix) {'//& - 'sx=#x;sy=#y;sz=[sx.1,sy.2];test "Matrices do not conform for multiplication"=>size(sx.2)==size(sy.1);'//& - 'test "Cannot multiply zero size matrices"=>size(x)>0 and size(y)>0;'//& - 'var z=matrix(b,sz) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& - 'for *i in sz,zz in z.array {'//& - 'var s=matrix_element_zero(_arb(z.array));'//& - 'foreach invar k in #(sx.1) {'//& - ' s:=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2]))};'//& - 'zz:=s};'//& - 'return z }',line) - - ! ***************************************** - ! DISTRIBUTED SHAPE (DSHAPE) - ! ***************************************** - - call dcl_type(parser,'_distrb(extent:extent,dist:distr or null)',line) - call dcl_type(parser,'_distrb(extent:extent,dist:distr) is ...,dshape(extent,dist)',line) - call dcl_type(parser,'_distrb(extent:extent,dist:null) is ...,mshape(extent)',line) - call dcl_type(parser,'shape(extent:extent,dist:distr or null) is _distrb(extent,dist)',line) - call dcl_type(parser,'shape1d(extent:extent1d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'shape2d(extent:extent2d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'shape3d(extent:extent3d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'shape4d(extent:extent4d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'shape5d(extent:extent5d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'shape6d(extent:extent6d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'shape7d(extent:extent7d,dist:distr or null) is shape(extent,dist)',line) - call dcl_type(parser,'PM__distr_tag is unique',line) - - call dcl_type(parser,'dshape(extent:extent,dist:distr) '//& - 'is rec {use _mshape:mshape(extent),dist:dist,_tile,'//& - '_tilesz,_size:int,_level:int,_dtag:PM__distr_tag}',line) - call dcl_uproc(parser,& - 'check_conform(x:dshape,y:mshape) { check_conform(x._mshape,y) }',line) - call dcl_uproc(parser,& - 'check_conform(x:mshape,y:dshape) { '//& - ' test "A distributed object connot conform to a non-distributed value" => ''false'//& - '}',line) - call dcl_uproc(parser,& - 'check_conform(x:dshape,y:dshape) { '//& - ' check_conform(x._mshape,y._mshape);'//& - ' test "Objects have different distributions"=>'//& - ' x.dist==y.dist }',line) - call dcl_uproc(parser,'conform(x:dshape,y:mshape)=conform(x._mshape,y)',line) - call dcl_uproc(parser,'conform(x:mshape,y:dshape)=''false',line) - call dcl_uproc(parser,'conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist',line) - call dcl_uproc(parser,'_local_size(x:dshape)=size(x._tile)',line) - - ! Get an element from a null tile - just pass index through - call dcl_uproc(parser,'_get_elem(x:null,y:tuple(index))=y',line) - call dcl_uproc(parser,'_get_elem(x:null,y:int)=y',line) - - call dcl_uproc(parser,'size(d:dshape)=d._size',line) - call dcl_uproc(parser,'#(d:dshape)=d',line) - - ! ***************************************** - ! DISTRIBUTED ARRAY AND SHAPE TEMPLATES - ! ***************************************** - - call dcl_type(parser,'darray_template(e,d,p,t) is '//& - 'rec {_e:e,_d:d,_p:p,_t:t,_v}',line) - - call dcl_type(parser,'dshape_template(d,p,t) is '//& - 'rec {_d:d,_p:p,_t:t}',line) - - call dcl_uproc(parser,'darray(e,d:extent)=array(e,d,VBLOCK)',line) - - call dcl_uproc(parser,'array(e,d:extent,'//& - 'distr:distr_template,topo:any=null)='//& - 'new darray_template {_e=e,_d=d,_p=distr,_t=topo,_v=''true}',line) - - call dcl_uproc(parser,'array(e,d:extent,distr:null or tuple(null))=array(e,d)',line) - - call dcl_uproc(parser,'dvarray(e,d:extent)=varray(e,d,VBLOCK)',line) - - call dcl_uproc(parser,'varray(e,d:extent,'//& - 'distr:distr_template,topo:any=null)='//& - 'new darray_template {_e=e,_d=d,_p=distr,_t=topo,_v=''true}',line) - - call dcl_uproc(parser,'varray(e,d:extent,distr:null or tuple(null))=varray(e,d)',line) - - call dcl_uproc(parser,'shape(d:extent,'//& - 'distr,topo:any=null)='//& - 'new dshape_template {_d=d,_p=distr,_t=topo}',line) - - - ! ***************************************** - ! DISTRIBUTED ARRAYS - ! ***************************************** - - call dcl_uproc(parser,& - 'PM__dup(d:darray_template) { '//& - ' dd=dims(d._d);'//& - ' topo=topology(d._t,d._p,dd,'//& - ' min(size(d._d),shrd_nnode()));'//& - ' dist=distribute(d._p,dd,topo);'//& - ' test "Not enough processors to implement distribution"=>'//& - ' size(#dist)<=shrd_nnode();'//& - ' p=_shrd_node();'//& - ' var elem=empty(dist);'//& - ' if p'//& - ' size(#dist)<=shrd_nnode();'//& - ' p=_shrd_node();'//& - ' var elem=empty(dist);'//& - ' if p ''false',line) - - call dcl_uproc(parser,'_arb(dd:any^dshape)=_get_aelem(dd,0)',line) - call dcl_uproc(parser,& - 'dims(dd:any^dshape)=dims((#dd)._mshape)',line) - - call dcl_uproc(parser,'PM__redim(a,d)=_redim(a,d)',line) - call dcl_uproc(parser,'PM__local(a:any^dshape)=_redim(a,(#a)._tilesz)',line) - call dcl_uproc(parser,'PM__local(a:any^mshape)=a',line) - call dcl_uproc(parser,'_get_elem(a:any^dshape,t) { '//& - 'p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& - 'var r=_arb(a);if p==_this_node():r:=_get_aelem(a,i);PM__broadcast(&r,p);return r} ',line) - call dcl_uproc(parser,'_set_elem(&a:any^dshape,v,t) {'//& - ' p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& - ' if p==_this_node():PM__setaelem(&a,i,v)}',line) - - - - !************************************************* - ! SLICES - !************************************************* - - ! Slices - call dcl_type(parser,'array_slice(a,s) is struct^{_a:a,_s:s}',line) - call dcl_uproc(parser,'_arb(x:array_slice)=_arb(x._a)',line) - call dcl_uproc(parser,'#(x:array_slice)=#(x._s)',line) - call dcl_uproc(parser,'conform(x:mshape,y:array_slice)='//& - 'map_reduce($_conform,$and,x,y._s)',line) - call dcl_uproc(parser,'conform(x:dshape,y:array_slice)='//& - 'map_reduce($_conform,$and,x._mshape,y._s)',line) - call dcl_uproc(parser,'conform(x,y:array_slice)='//& - 'map_reduce($_conform,$and,#x,y._s)',line) - call dcl_uproc(parser,'dims(x:array_slice)=dims(x._s)',line) - call dcl_uproc(parser,'size(x:array_slice)=size(x._s)',line) - call dcl_uproc(parser,'_get_elem(x:array_slice(any^mshape,),y:index)=_get_elem(x._a,x._s[y])',line) - call dcl_uproc(parser,'_get_elem(x:array_slice,y:subs)=new array_slice {_a=x._a,_s=x._s[y]}',line) - call dcl_uproc(parser,'_set_elem(&x:array_slice(any^mshape,),v,y:index)'//& - ' {PM__setaelem(&^(x._a),index(##(x._a),x._s[y]),v)}',line) - call dcl_uproc(parser,'PM__dup(x:array_slice(any^mshape,))'//& - '{var a=array(_arb(x),#x);a:=x;return a}',line) - - !************************************************* - ! ARRAY & SLICE ASSIGNMENT - !************************************************* - - call dcl_uproc(parser,'PM__assign(&xx:farray,x:any)'//& - ' {check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) - call dcl_uproc(parser,'PM__assign(&xx:farray,x:array) '//& - '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& - line) - call dcl_uproc(parser,'PM__assign(&xx:varray,x:farray) '//& - '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& - line) - call dcl_uproc(parser,'PM__assign_var(&xx:farray,x:any)'//& - ' {check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) - call dcl_uproc(parser,'PM__assign_var(&xx:farray,x:array) '//& - '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& - line) - call dcl_uproc(parser,'PM__assign_var(&xx:varray,x:farray) '//& - '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& - line) - call dcl_uproc(parser,'_array_assign(&xx,x,v:''false)'//& - '{check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) - call dcl_uproc(parser,'_array_assign(&xx,x,v:''true)'//& - '{check_conform(extent(#xx),extent(#x));'//& - 'if _copy_array(&xx,x):_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'_array_assign(&xx:varray,x,v:''true) '//& - '{_assign_element(&xx,x)}',line) - call dcl_uproc(parser,'_array_assign(&xx:varray,x:array_template,v:''true) '//& - '{_assign_element(&xx,PM__dup(x))}',line) - - call dcl_uproc(parser,'_set_slice(&x,a,y,b) {x[a]:=y[b]}',line) - - call dcl_type(parser,'_non_d is any^mshape,array_slice(any^mshape,)',line) - - call dcl_uproc(parser,'_set_array(&x:any^mshape,y)'//& - '{for i in x <>{ _assign(&i,y) } } ',line) - call dcl_uproc(parser,'_set_array(&x:any^dshape,y)'//& - '{_set_array(&^(PM__local(^(&x))),y)}',line) - call dcl_uproc(parser,'_set_array(&x:array_slice(any^mshape,),y)'//& - '{for i in x._s <>{_set_elem(&x._a,y,i <>) }}',line) - call dcl_uproc(parser,'_set_array(&x:array_slice(any^dshape,),y){'//& - 'tile=(#x._a)._tile;'//& - 't=overlap(tile,((#x._a)#x._s));'//& - 'for i in t <>{ '//& - ' _set_elem(&x._a,y,i <>) '//& - '}}',line) - - call dcl_uproc(parser,'_copy_array(&a:_non_d,b:_non_d)'//& - '{for i in a, j in b <>{i:=j};return ''false}',line) - - call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:_non_d) {'//& - 'tile=(#xx)._tile;'//& - 'for i in tile <>{PM__setaelem(&xx,'//& - 'index(dims(tile),here),x[i] <>)};return ''false }',& - line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:_non_d) {'//& - 'tile=(#xx._a)._tile;subtile,subarray=overlap(tile,xx._s);'//& - 'for i in subtile,j in subarray <>{'//& - ' PM__setaelem(&xx._a,index(dims(tile),i),x[j] <>) };return ''false }',& - line) - - call dcl_uproc(parser,'_copy_array(&a:_non_d,x:any^dshape) {'//& - ' dist=(#x).dist; '//& - ' foreach p in #(dist) {'//& - ' tile=_get_elem(dist,p);'//& - ' i=index(dims(dist),p);'//& - ' if i==_this_node() { '//& - ' for kk in PM__local(x),j in tile <>{ '//& - ' var k=kk;PM__broadcast(&k,i);'//& - ' _set_elem(&a,k,j <>)'//& - ' }'//& - ' } else { '//& - ' for j in tile <>{ '//& - ' var k=_arb(a);'//& - ' PM__broadcast(&k,i);'//& - ' _set_elem(&a,k,j <>);'//& - ' }'//& - ' }'//& - ' };return ''false}',& - line) - - call dcl_uproc(parser,'_copy_array(&v:_non_d,x:array_slice(any^dshape,)) {'//& - ' dist=(#(x._a)).dist;xs=(#(x._a))._mshape#x._s;'//& - ' nodes=#dist;'//& - ' foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) {'//& - ' p=nodes[pp];utile,elem=overlap(dist[nodes[p]],xs);'//& - ' i=index(dims(dist),p);'//& - ' if i==_this_node() {'//& - ' for j in utile, jj in elem <>{ '//& - ' var k=_get_elem(PM__local(x._a),j); '//& - ' PM__broadcast(&k,i);'//& - ' _set_elem(&v,k,jj <>)'//& - ' }'//& - ' } else { '//& - ' for j in elem <>{'//& - ' var k=_arb(x._a);'//& - ' PM__broadcast(&k,i);'//& - ' _set_elem(&v,k,j <>)'//& - ' }'//& - ' }'//& - ' };return ''false}',& - line) - - call dcl_uproc(parser,'_copy_array(&x:any^mshape,y:array_template) '//& - '{_set_array(&x,y._a);return ''false }',line) - call dcl_uproc(parser,'_copy_array(&x:any^dshape,y:array_template) {'//& - '_set_array(&^(PM__local(^(&x))),y._a);return ''false}',line) - - call dcl_type(parser,'_comp is contains(array or *any or ^*(,,,,))',line) - - call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:any^dshape) {'//& - 'newd=#xx;oldd=#x;'//& - 'foreach pp in nodes_for_grid(oldd.dist,newd._tile) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(oldd.dist,p);'//& - ' _recv_slice(p,&xx,overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,oldd._tile) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(newd.dist,p);'//& - ' _send_slice(p,x,overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x),oo);'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),'//& - 'x:array_slice(any^dshape,)) {'//& - 'newd=#(xx._a);oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;xxs=(#(xx._a))._mshape#xx._s;'//& - 'oldpart,oldtile=overlap(xs,oldd._tile);'//& - 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newpart)) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,overlap(xs,_get_elem(oldd.dist,p)));'//& - ' _recv_slice(p,&^(PM__local(^(&xx._a))),overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldpart)) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,overlap(xxs,_get_elem(newd.dist,p)));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:array_slice(any^dshape,)) {'//& - 'newd=#(xx);oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;'//& - 'oldpart,oldtile=overlap(xs,oldd._tile);'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newd._tile)) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xs,_get_elem(oldd.dist,p));'//& - ' _recv_slice(p,&^(PM__local(^(&xx))),overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,oldpart) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:any^dshape) {'//& - 'newd=#(xx._a);oldd=#x;'//& - 'xxs=(#(xx._a))._mshape#xx._s;'//& - 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(oldd.dist,newpart) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,_get_elem(oldd.dist,p));'//& - ' _recv_slice(p,&^(PM__local(^(&xx._a))),overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldd._tile)) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xxs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x),'//& - ' oo);'//& - 'return ''true}',line) - - - call dcl_uproc(parser,'_copy_array(&xx:_comp^dshape,x:any^dshape) {'//& - 'newd=#xx;oldd=#x;'//& - 'foreach pp in nodes_for_grid(newd.dist,oldd._tile) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(newd.dist,p);'//& - ' _send_slice(p,PM__local(x),overlap(oldd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(oldd.dist,newd._tile) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(oldd.dist,p);'//& - ' _recv_slice_sync(p,&^(PM__local(^(&xx))),overlap(newd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x),oo);'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(_comp^dshape,),'//& - 'x:array_slice(any^dshape,)) {'//& - 'newd=#(xx._a);oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;xxs=(#(xx._a))._mshape#xx._s;'//& - 'oldpart,oldtile=overlap(xs,oldd._tile);'//& - 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldpart)) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,overlap(xxs,_get_elem(newd.dist,p)));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newpart)) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,overlap(xs,_get_elem(oldd.dist,p)));'//& - ' _recv_slice_sync(p,&xx._a,overlap(newd._tile,tile))}'//& - '};'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:_comp^dshape,x:array_slice(any^dshape,)) {'//& - 'newd=#xx;oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;'//& - 'oldpart,oldtile=overlap(xs,oldd._tile);'//& - 'foreach pp in nodes_for_grid(newd.dist,oldpart) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newd._tile)) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xs,_get_elem(oldd.dist,p));'//& - ' _recv_slice_sync(p,&^(PM__local(^(&xx))),overlap(newd._tile,tile))}'//& - '};'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(_comp^dshape,),x:any^dshape) {'//& - 'newd=#(xx._a);oldd=#x;'//& - 'xxs=(#(xx._a))._mshape#xx._s;'//& - 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldd._tile)) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xxs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x),'//& - ' oo);'//& - 'foreach pp in nodes_for_grid(oldd.dist,newpart) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,_get_elem(oldd.dist,p));'//& - ' _recv_slice_sync(p,&^(PM__local(^(&xx._a))),overlap(newd._tile,tile))}'//& - '};'//& - 'return ''true}',line) - - !************************************************* - ! REFERENCES (SUBSCRIPTS AND SLICES) - !************************************************* - - ! Reference type for & args - call dcl_type(parser,'PM__reftype(x) is x,^shared(x,,,,)',line) - - ! Support for internal ^(...) reference type - call dcl_proc(parser,'_v1(x:any)->PM__d1 x',op_elem,1,line,0) - call dcl_proc(parser,'_v2(x:any)->PM__d2 x',op_elem,2,line,0) - call dcl_proc(parser,'_v3(x:any)->PM__d3 x',op_elem,3,line,0) - call dcl_proc(parser,'_v4(x:any)->PM__d4 x',op_elem,4,line,0) - call dcl_proc(parser,'_v5(x:any)->PM__d5 x',op_elem,5,line,0) - - call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->PM__d1% x',op_elem,1,line,0) - call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->PM__d2% x',op_elem,2,line,0) - call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->PM__d3% x',op_elem,3,line,0) - call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->PM__d4% x',op_elem,4,line,0) - call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->PM__d5% x',op_elem,5,line,0) - - ! Right hand side references - call dcl_uproc(parser,'_make_null(x)=null',line) - call dcl_uproc(parser,& - 'PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) - call dcl_uproc(parser,'PM__subref(x,t:subs)'//& - '{tt=_tup(t);check_contains(#x,tt);return _subref(x,tt) }',line) - call dcl_uproc(parser,'PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x))',line) - call dcl_uproc(parser,'PM__subref(x:^*(,,,,),t:null)='//& - 'PM__subref(x,map($_make_null,#_v1(x)))',line) - call dcl_uproc(parser,'_subref(x:any^mshape,t:index)=_get_elem(x,t)',line) - call dcl_uproc(parser,'_subref(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t)}',line) - call dcl_uproc(parser,'_subref(x:array_slice(any^mshape,),t:index)=_get_elem(x._a,x._s[t])',line) - call dcl_uproc(parser,'_subref(x:array_slice,t:subs)=new array_slice {_a=x._a,_s=x._s[t]}',line) - call dcl_uproc(parser,'_subref(x:any^dshape,t:index)='//& - ' PM__ref(_arb(x),x,i,p,_s_ref)'//& - ' where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t))',line) - call dcl_uproc(parser,'_subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t])',line) - call dcl_uproc(parser,'_subref(a:^*(,,,,),t)='//& - 'PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a))',line) - call dcl_uproc(parser,'_subref(a,t)=$[](a,t)',line) - call dcl_uproc(parser,'[](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...)))',line) - - ! Left hand side references - call dcl_uproc(parser,& - 'PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) - call dcl_uproc(parser,'PM__sublhsamp(x,t:subs)'//& - ' {tt=_tup(t);check_contains(#x,tt);return _sublhs(x,tt)}',line) - call dcl_uproc(parser,'PM__sublhsamp(x:any^dshape,t:subs)'//& - ' {test "Cannot have subscript of a distributed array in ""&"" argument"=>''false;'//& - ' return _arb(x)}',line) - call dcl_uproc(parser,& - 'PM__sublhs(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) - call dcl_uproc(parser,'PM__sublhs(x,t:subs)'//& - ' {tt=_tup(t);check_contains(#x,tt);return _sublhs(x,tt)}',line) - call dcl_uproc(parser,'PM__sublhs(x:^!(,,,,),t:subs)'//& - ' {tt=_tup(t);return _sublhs(x,tt)}',line) - call dcl_uproc(parser,& - 'PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x))',line) - call dcl_uproc(parser,'PM__sublhs(x:^!(,,,,),t:null)='//& - 'PM__sublhs(x,map($_make_null,#_v1(x)))',line) - call dcl_uproc(parser,'_sublhs(x:any^mshape,t:index)=_make_subref(x,t)',line) - call dcl_uproc(parser,& - '_sublhs(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t)}',line) - call dcl_uproc(parser,'_sublhs(x:array_slice(any^mshape,),t:index)='//& - '_make_subref(x._a,x._s[t])',line) - call dcl_uproc(parser,'_sublhs(x:array_slice,t:subs)='//& - 'new array_slice {_a=x._a,_s=x._s[t]}',line) - call dcl_uproc(parser,'_sublhs(x:any^dshape,t:index)='//& - ' PM__ref(_arb(x),x,i,p,_s_ref)'//& - ' where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t))',line) - call dcl_uproc(parser,'_sublhs(a:^!(,,,,),t)='//& - 'PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a))',line) - call dcl_uproc(parser,'[](&a:array,v,arg...)'//& - '{ PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v)}',line) - - ! Realise a reference - call dcl_uproc(parser,'PM__valref(x)=x',line) - call dcl_uproc(parser,'PM__valref(x:^*(,,,,)) {'//& - ' var v=_v1(x);if _v4(x)==_this_node() { v:=_getref(x,null)};'//& - ' PM__broadcast(&v,_v4(x));return v }',line) - !call dcl_uproc(parser,'PM__getref(x:^!(,,,,))=PM__valref(x)',line) - - ! Assign to a reference - call dcl_uproc(parser,'PM__assign(&x:^*(,,,,),y) {'//& - 'check_assign_types(_v1(^(&x)),y);'//& - 'if _v4(^(&x))==_this_node() { PM__assign(&^(_getlhs(^(&x),null)),y) }}',line) - - ! ************************************************************* - ! DISTRIBUTED REFERENCES - ! ************************************************************* - - ! Distributed reference is an internal compiler type - ! ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode) - ! mode is: - ! null -- local reference - ! _s_ref -- shrd index on darray, only shrd/indexed otherwise - ! _sp_ref -- shrd index on darray, some priv after (or before) - ! _d_ref -- indexed index on darray, shrd/indexed otherwise - ! _dp_ref -- indexed index on darray, some priv after (or before) - ! _p_ref -- priv index on darray and possibly elsewhere - - call dcl_type(parser,'_s_ref is unique',line) - call dcl_type(parser,'_sp_ref is unique',line) - call dcl_type(parser,'_d_ref is unique',line) - call dcl_type(parser,'_dp_ref is unique',line) - call dcl_type(parser,'_p_ref is unique',line) - - call dcl_proc(parser,& - '_import_dref%(r:any,s:any,h:any,x:any)->^^x',op_import_dref,0,line,0) - - ! Some trivial referencing cases - call dcl_uproc(parser,'PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t)',line) - call dcl_uproc(parser,'PM__sublhsamp%(x:any^dshape,t:subs)'//& - ' {test "Cannot have subscript of a distributed array in ""&"" argument"=>''false;'//& - ' return _arb(x)}',line) - call dcl_uproc(parser,'PM__sublhs%(x,y)=PM__subref%(x,y)',line) - call dcl_uproc(parser,'PM__sublhs%(x:priv ^*(,,,,),y)=PM__subref%(x,y)',line) - call dcl_uproc(parser,'PM__sublhs%(x:priv,y)=PM__sublhs(x,y):'//& - 'test """sync"" assignment updating a private variable"=>''false',line) - call dcl_uproc(parser,'PM__subref%(x:priv,y)=PM__subref(x,y)',line) - call dcl_uproc(parser,'PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y)',line) - call dcl_uproc(parser,'PM__subref%(x:priv,y:invar indexed)=PM__subref(x,*y)',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^mshape,y:index)=PM__subref(x,y)',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^mshape,y:subs)=PM__subref(x,y)',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^mshape,y:invar indexed)='//& - 'PM__subref(x,_dmap(y,here))',line) - call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):'//& - 'test """sync"" assignment updating a private variable"=>''false',line) - call dcl_uproc(parser,'PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y)',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:any^dshape,y)=_arb(x)'//& - ':test "Cannot subscript distributed array in ""for <>""" => ''false',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^dshape,y:invar indexed)='//& - '_arb(x)'//& - ':test "Cannot subscript distributed array in ""for <>""" => ''false',line) - call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y)',line) - call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,tuple(y <>))',line) - - - ! Reference of non-distributed array with priv or indexed subscript - call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:index)'//& - '{tt=_tup(t);check_contains(#x,tt);i=index(#x,tt);'//& - 'return PM__dref(_get_aelem(x,i),x,i,null,null)}',line) - call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:subs)'//& - '{tt=_tup(t);check_contains(#x,tt);return PM__drefs(x,x,tt,null,null)}',line) - call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:invar indexed)='//& - 'PM__subref%(x,_dmap(t,here))',line) - call dcl_uproc(parser,& - 'PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t])',line) - call dcl_uproc(parser,'PM__subref%(x,t)='//& - 'PM__dref($[](x,t),x,t,null,null)',line) - - ! Subscript or slice of distributed array - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) <>'//& - '{tt=_tup(t <>);check_contains(#(x),tt);'//& - 'return PM__dref(_arb(x),x,i,p,_s_ref) '//& - 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:index)'//& - '{tt=_tup(t);check_contains(#(x),tt);'//& - 'return PM__dref(_arb(x),x,i,p,_p_ref) '//& - 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:subs)'//& - '{tt=_tup(t);check_contains(#(x),tt);var xx=varray(_arb(x),empty(#x));'//& - 'return PM__drefs(xx,x,tt,p,_p_ref) '//& - 'where p=nodes_for_grid((#x).dist,tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed) <> {'//& - 'check_contains(#x,_dmap(t,here));'//& - 'return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t)}',line) - - ! Subscript or slice of non-distristuted array which is itself result of variant slice - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index)'//& - '{tt=_tup(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt)'//& - 'return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null)}',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){'//& - 'tt=_tup(t <>);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& - 'return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null)}',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) {'//& - 'tt=_tup(t);check_contains(#(_v1%(x)),tt);'//& - 'return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null)}',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)='//& - 'PM__subref%(x,_dmap(t,here))',line) - - ! Subscript or slice of darray which is itself the result of a priv subscript - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index)'//& - '{tt=_tup(t);check_contains(#_v1%(x),tt);'//& - 'return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) '//& - 'where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:subs)'//& - '{tt=_tup(t);check_contains(#_v1%(x),tt);'//& - 'return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) '//& - 'where p=nodes_for_grid((#_v1%(x)).dist,tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)='//& - 'PM__subref%(x,_dmap(t,here))',line) - - ! Subscript of a priv slice - call dcl_uproc(parser,'PM__subref%(x:priv ^#(,,,null,null),t:subs)='//& - 'PM__subref%(_v2%(x),_v3%(x)[_tup(t)])',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)='//& - 'PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here)',line) - - ! Subscript of distributed reference - call dcl_uproc(parser,'_arb%(x:partial)=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:complete)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:chan)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:invar)=_arb(x <>)',line) - - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)='//& - 'PM__dref(_arb%(_v1%(x)),x,_tup(t))',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)='//& - 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref)',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar indexed)='//& - 'PM__subref%(x,_dmap(_tup(t),here))',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:invar indexed)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) - call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)='//& - 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref)',line) - - ! Node .[] subscript of distributed array - call dcl_type(parser,'_lcl is unique{_LCL}',line) - call dcl_uproc(parser,'PM__nodelhs%(x,y)=PM__noderef%(x,y)',line) - call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)='//& - '^(PM__import_val(PM__local(x)),coherent)',line) - call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:invar any_int){'//& - 'xd=#((#x).dist);check_contains(xd,y);'//& - 'return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)'//& - 'where p=index(xd,int(y))}',line) - call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:priv any_int){'//& - 'xd=#((#x).dist);check_contains(xd,y);'//& - 'return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)'//& - 'where p=index(xd,y)}',line) - call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:shared indexed)='//& - 'PM__noderef%(x,*y)',line) - call dcl_uproc(parser,'PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:invar any_int){'//& - 'xd=#((#x).dist);check_contains(xd,y);'//& - 'return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)'//& - 'where p=index(xd,int(y))}',line) - call dcl_uproc(parser,'PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:priv any_int){'//& - 'xd=#((#x).dist);check_contains(xd,y);'//& - 'return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)'//& - 'where p=index(xd,int(y))}',line) - call dcl_uproc(parser,'PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:shared indexed)='//& - 'PM__noderef%(x,*y)',line) - call dcl_uproc(parser,'PM__noderef%(x,y)=error_type() {'//& - 'if not region is {'//& - ' test """.[]"" subscript in non-distributed region"=>''false'//& - '} elseif x is {'//& - ' test """.[]"" subscript cannot be applied to a mirrored array"=>''false'//& - '} elseif not x is {'//& - ' test """.[]"" subscript applied to a non-array"=>''false'//& - '} elseif not y is {'//& - ' test """.[]"" subscript must have an integer value"=>''false'//& - '} else {'//& - ' test "Incorrect "".[]"" subscript"=>''false'//& - '}}',line) - - ! May need to cap off reference with here - call dcl_type(parser,'_here(t) is rec {here:t}',line) - call dcl_uproc(parser,'_cap%(x,h)<>=x',line) - call dcl_uproc(parser,'_cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) - call dcl_uproc(parser,'_capn%(x,h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) - - ! Treat @ variables differently only for limited circumstances in drefs - call dcl_uproc(parser,'_drat(at,tile,t)=''false',line) - call dcl_uproc(parser,'_drat(at:''true,tile:tuple(range or block_seq),t:indexed and _dr)=''true',line) - call dcl_type(parser,'_di(n) is indexed_dim(''1,''1,,n) or int',line) - call dcl_type(parser,'_dr is [_di(''1)],[_di(''1),_di(''2)],'//& - '[_di(''1),_di(''2),_di(''3)],[_di(''1),_di(''2),_di(''3),_di(''4)],'//& - '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5)],'//& - '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5),_di(''6)],'//& - '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5),_di(''6),_di(''7)]',line) - - ! Resolve a distributed reference - call dcl_uproc(parser,'PM__getref%(x,at)=x',line) - call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x)',line) - call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,int,_p_ref),at) {'//& - 'PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null);return v}',line) - call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,int,_sp_ref),at) {'//& - 'PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null);return v}',line) - call dcl_uproc(parser,'_scatter(x,region) {'//& - 'if _this_node()==_v4(x):foreach node in #region.dist {'//& - ' d=#region._mshape;a={_getref(_import_dref%(x),j): j in d};'//& - ' p=index(dims(region.dist),node);'//& - ' _send_slice(p,a,region.dist[node])}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) <> {'//& - 'chan var xx=_v1%(x);_getref_s(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_s(&xx,region,x,at) {'//& - 'PM__head_node{_irecv(_v4(x),&xx)};'//& - '_scatter(x,region);'//& - '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete _comp and ^*(,,,int,_s_ref),at:invar) <>{'//& - 'chan var xx=_v1%(x);_getref_sc(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_sc(&xx,region,x,at) {'//& - '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& - '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) <> {'//& - 'chan var a=_v1%(x);_getref_d(&^(PM__local(^(&a@) <>)),region,subregion(schedule),'//& - '^^(x),at <>);'//& - '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_d(&a,region,subregion,x,at) {'//& - '_get_dindex_from_dref(&a,x,t.2,'//& - '_local_region(region._tile,subregion),region,t.1,'//& - '_drat(at,region._tile,t.1)) where t=_v4(x)'//& - '}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) <> {'//& - 'chan var a=_arb(_v2%(x));'//& - '_getref_dc(&a@,region,subregion(schedule),^^(x),at <>);_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dc(&a,region,subregion,x,at) {'//& - 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& - '_local_region(region._tile,subregion),region,t.1,_drat(at,region._tile,t.1)) '//& - ' where t=_v4(x)}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) <> {'//& - 'chan var a=_v1%(x);'//& - '_getref_dp(&^(^^(^(&a))),region,subregion(schedule),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& - '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dp(&a,region,subregion,x,at,atq,t) {'//& - 'PM__head_node{_get_dindex_from_ref(&a,x,t.2,'//& - ' _local_region(region._tile,subregion),region,'//& - ' t.1,atq,_drat(at,region._tile,t.1))}'//& - '}',line) - - call dcl_uproc(parser,'PM__getref%(x:priv ^#(,,,,),at) {'//& - 'var v=varray(_arb(_v1%(x)),#_v3%(x));'//& - 'var vv=varray(_arb(_v1%(x)),empty(#_v1%(x)));'//& - 'foreach p in _v4%(x) {'//& - ' dist=(#(_getref(_v2%(x),null))).dist;'//& - ' u=overlap(_v3%(x),dist[p]);'//& - ' ppp=index(dims(dist),p);'//& - ' PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null);'//& - ' v[u]:=vvv};return v}',line) - - - ! Resolve reference locally (once communicated) - call dcl_uproc(parser,'_getref_elem(x:any^mshape,i)=_get_aelem(x,i)',line) - call dcl_uproc(parser,& - '_getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i)',line) - call dcl_uproc(parser,& - '_getref(x:^*(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x))',line) - call dcl_uproc(parser,'_getref(x:^*(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here)',line) - call dcl_uproc(parser,'_getref(x:^*(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)]',line) - call dcl_uproc(parser,'_getref(x:^*(,,null,,),y)<>=_getref(_v2(x),y)',line) - call dcl_uproc(parser,'_getref(x:^*(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y))',line) - call dcl_uproc(parser,'_getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x)',line) - call dcl_uproc(parser,'_getref(x:^shared(,null,null,null,null),y)<>=_v1(x)',line) - call dcl_uproc(parser,'_getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x))',line) - call dcl_uproc(parser,'_getslice(x:any^dshape,tt) {t=overlap((#x)._tile,tt);'//& - 'var v=varray(_arb(x),#t);v:=PM__local(x)[t];return v}',line) - call dcl_uproc(parser,'_getslice(x:any^mshape,t) {'//& - 'var v=varray(_arb(x),#t);v:=x[t];return v}',line) - call dcl_uproc(parser,'_getref(x:any^any,y)=x',line) - call dcl_uproc(parser,'_getref(x:^shared(,,indexed,,),y)<>='//& - '_getref(_v2(x),y)[_dmap(_v3(x),y)]',line) - call dcl_uproc(parser,'_getref(x:^shared(,any^dshape,indexed,,),y)<>='//& - '_get_elem(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) '//& - 'where ms=#_v2(x)',line) - call dcl_uproc(parser,'_getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) '//& - ':test "Internal error - uncapped dref" => ''false',line) - - - if(pm_is_compiling) then - call dcl_proc(parser,'_sync%(any,any,any,&x:any)',op_sync,0,line,0) - else - call dcl_uproc(parser,'_sync%(&x:any){}',line) - endif - - ! Assignment of distributed and/or shared or uniform references - call dcl_uproc(parser,'PM__assign%(&x:priv,y,at) {'//& - '_sync%(&x);PM__assign(&x,y <>)}',line) - call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_assign_to_invar%(&x,y) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) - call dcl_uproc(parser,& - '_assign_to_invar%(&x:invar,y:priv) '//& - '{ test "Can only assign an ""invar"" value to an ""invar"" variable" => ''false }',line) - - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) {'//& - 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy)};'//& - 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,''false {'//& - ' test "Cannot assign element twice in same assignment"=>'//& - ' _getref(xx,null)==yy } }',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,at) {'//& - 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y) }}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y,at) {'//& - 'foreach invar p in 0..size(#region.dist)-1 {'//& - ' PM__bcast xx,yy,_cap%(x,here),y,p {'//& - ' PM__assign(&^(_getlhs(^(&xx),null)),yy) }};'//& - 'foreach invar p in 0..size(#region.dist)-1 {'//& - ' PM__bcast xx,yy,_cap%(x,here),y,p {'//& - ' test "Cannot assign an element two different values in a single assignment"=>'//& - ' _getref(xx,null)==yy}}}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y:invar,at) {'//& - '_sync%(&x);var xx=_import_dref%(x);PM__assign(&^(_getlhs(^(&xx),here)),y)}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,at) {'//& - '_sync%(&x);PM__assign(&^(_v1%(^(&x))),y)}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) {'//& - 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy)};'//& - 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,''false '//& - ' { test "Cannot assign element to two different values in same assignment"=>'//& - ' _getref(xx,null)==yy }}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:invar,at) {'//& - 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at '//& - '{ PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y))}}',line) - - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) {'//& - '_set_ref_dp(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& - ' region,subregion(schedule),$_just_assign,^^(^??),at,_v4(x) <>)}',line) - call dcl_uproc(parser,'_just_assign(x,y)=y',line) - call dcl_uproc(parser,'_set_ref_dp(&x,y,region,subregion,prc,atq,at,t) {'//& - '_set_dindex_of_ref(&x,y,t.2,'//& - '_local_region(region._tile,subregion),'//& - 'region,t.1,prc,atq,at)'//& - '}',line) - - ! Operater assignment: x =y - call dcl_uproc(parser,'PM__assign%(&x:priv,y:priv,pr,at) {PM__assign(&x,y,pr)}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv,y:invar,pr,at) {PM__assign(&x,y,pr)}',line) - call dcl_uproc(parser,'PM__assign%(&x:invar,y,pr,at) { _assign_to_invar%(&x,y,pr,at) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:invar,y:priv,pr,at){'//& - '_assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at)}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) {'//& - 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,pr,at) {'//& - 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr) }}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) {'//& - 'foreach invar p in 0..size(region.dist)-1 {'//& - ' PM__bcast xx,yy,_cap%(x,here),y,p {'//& - ' PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) }}}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y:invar,pr,at) {'//& - 'var xx=_import_dref%(x);PM__assign(&^(_getlhs(^(&xx),here)),y,pr)}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,pr,at) {'//& - 'PM__assign(&^(_v1%(^(&x))),y,pr)}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:priv,pr,at) {'//& - 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) {'//& - 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr)}}',line) - call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) {'//& - '_set_dindex_of_ref(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& - '_local_region(region._tile,subregion(schedule)),'//& - 'region,t.1,pr,^^(^??),at <>)'//& - 'where t=_v4%(x)}',line) - - ! Resolve LHS reference (locally after communication) - call dcl_uproc(parser,'_getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here)',line) - call dcl_uproc(parser,'_getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y)',line) - call dcl_uproc(parser,'_getlhs(x:^(,,int,,),y)='//& - '_make_subref(_getlhs(_v2(x),y),int(_v3(x)))',line) - call dcl_uproc(parser,'_getlhs(x:^shared(,,null,,),y)=_getlhs(_v2(x),y)',line) - call dcl_uproc(parser,'_getlhs(x:^shared(,,int,,),y)='//& - '_make_subref(_getlhs(_v2(x),y),int(_v3(x)))',line) - call dcl_uproc(parser,'_getlhs(x:^(,,subs,,),y)='//& - 'PM__sublhs(_getlhs(_v2(x),y),_v3(x))',line) - call dcl_uproc(parser,'_getlhs(x:^shared(,,subs,,),y)='//& - 'PM__sublhs(_getlhs(_v2(x),y),_v3(x)) ',line) - call dcl_uproc(parser,& - '_local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t))',line) - call dcl_uproc(parser,'_getlhs(x:^#(,,subs,,),y)<>=_local_ref(x,_v3(x))',line) - call dcl_uproc(parser,'_getlhs(x:^#shared(,,subs,,),y)<>=_local_ref(x,_v3(x))',line) - call dcl_uproc(parser,'_getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x)',line) - call dcl_uproc(parser,'_getlhs(x:^shared(,null,null,null,null),y)<>=_v1(x)',line) - call dcl_uproc(parser,'_getlhs(x:^(,null,null,null,null),y)<>=_v1(x)',line) - call dcl_uproc(parser,'_getlhs(x:any^any,y)=x',line) - call dcl_uproc(parser,'_getlhs(x:any^dshape,y)=PM__local(x)',line) - call dcl_uproc(parser,'_getlhs(x:^shared(,,indexed,,),y)<>='//& - '_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y))',line) - call dcl_uproc(parser,'_getlhs(x:^shared(,any^dshape,indexed,,),y)<>='//& - '_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) '//& - 'where ms=#_v2(x)',line) - - call dcl_uproc(parser,'_getlhs(x:^shared(,,indexed,,),y:null)='//& - '_v1(x) :test "Internal error -- uncapped indexed ref" => ''false',line) - - !************************************************************** - ! INDEXED VARIABLES - !************************************************************** - - call dcl_type(parser,'indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m=''1,_c:c=''0,_d:d=''1,_n:n}',line) - call dcl_type(parser,'indexed(t:int) is tuple(indexed_dim or int) except tuple(int)',line) - call dcl_uproc(parser,'PM__makeidxdim(x:null,y)=new indexed_dim {_n=y}',line) - call dcl_uproc(parser,'PM__makeidxdim(x:null)=new indexed_dim {_n=null}',line) - call dcl_uproc(parser,'PM__makeidxdim(x:range,y)=new indexed_dim {_c=x._lo,_n=y}',line) - call dcl_uproc(parser,'PM__makeidxdim(x:strided_range,y)=new indexed_dim {_c=x._lo,_m=x._st,_n=y}',line) - call dcl_uproc(parser,'PM__makeidxdim(x,y)=PM__makeidxdim(get_dim(x,y),y)',line) - call dcl_uproc(parser,'PM__makeidxdim(x:tuple)'//& - '=map($PM__makeidxdim,x,indices(x))',line) - call dcl_uproc(parser,'PM__makeidxdim(x:seq)=[PM__makeidxdim(x,''1)]',line) - - - !!! Obsolete? - call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or tuple(indexed_dim or int))='//& - 'new _indexed {_t=_tup(x),_r=null}',line) - call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or tuple(indexed_dim or int),y)='//& - 'new _indexed {_t=_tup(x),_r=y}',line) - call dcl_uproc(parser,'PM__makeidx(x,y)=x :test "Malformed indexed expression" => ''false',line) - call dcl_uproc(parser,'PM__makeidx(x)=x :test "Malformed indexed expression" => ''false',line) - - call dcl_uproc(parser,'*%(x:indexed)=_dmap(x,here)',line) - call dcl_uproc(parser,'*%(x)=here check'//& - '"""*"" operator can only be applied to an ""indexed"" value"=>''false',line) - call dcl_uproc(parser,'*(x)=x check'//& - '"""*"" operator cannot be applied outside of a parallel context"=>''false',line) - - call dcl_uproc(parser,'+(x:indexed_dim,yy:any_int)='//& - 'new indexed_dim {_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'+(yy:any_int,x:indexed_dim)='//& - 'new indexed_dim {_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'-(x:indexed_dim,yy:any_int)='//& - 'new indexed_dim {_m=x._m,_c=x._c-y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'-(yy:any_int,x:indexed_dim)='//& - 'new indexed_dim {_m=-x._m,_c=-x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'*(x:indexed_dim,yy:any_int)='//& - 'new indexed_dim {_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'*(yy:any_int,x:indexed_dim)='//& - 'new indexed_dim {_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'/(x:indexed_dim,yy:any_int)='//& - 'new indexed_dim {_m=x._m,_c=x._c,_d=x._d*y,_n=x._n} where y=int(yy)',line) - call dcl_uproc(parser,'+(x:indexed_dim,y:indexed_dim)='//& - 'new indexed_dim {_m=x._m*y._d+y._m*x._d,_c=x._c*y._d+y._c*x._d,_d=x._d*y._d,_n=x._n}',line) - call dcl_uproc(parser,'-(x:indexed_dim,y:indexed_dim)='//& - 'new indexed_dim {_m=x._m*y._d-y._m*x._d,_c=x._c*y._d-y._c*x._d,_d=x._d*y._d,_n=x._n}',line) - - call dcl_uproc(parser,'string(x:indexed_dim)="($here."++x._n++"*"++x._m++"+"++x._c++")/"++x._d',line) - call dcl_uproc(parser,'string(x:indexed_dim(''1))="$here."++x._n++"*"++x._m++"+"++x._c',line) - call dcl_uproc(parser,'string(x:indexed_dim(''1,''1))="$here."++x._n++"+"++x._c',line) - call dcl_uproc(parser,'string(x:indexed_dim(''1,''1,''0))="$here."++x._n',line) - - call dcl_uproc(parser,'_correct(x:tuple(indexed_dim),y:extent)=map($-,x,low(y))',line) - - call dcl_uproc(parser,'_dmap(x:any_int,n:int)=x',line) - call dcl_uproc(parser,'_dmap(x:any_int,n:grid_slice_dim)=single_point(x)',line) - call dcl_uproc(parser,'_dmap(x:any_int,n:tuple(int))=x',line) - call dcl_uproc(parser,'_dmap(x:any_int,n:tuple(grid_slice_dim))=single_point(x)',line) - call dcl_uproc(parser,'_dmap(x:indexed_dim,n:int)=(n*x._m+x._c)/x._d',line) - call dcl_uproc(parser,'_dmap(x:indexed_dim,n:tuple)=_dmap(x,get_dim(n,x._n))',line) - call dcl_uproc(parser,'_dmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi)'//& - 'where lo=_dmap(x,low(n)),hi=_dmap(x,high(n))',line) - call dcl_uproc(parser,'_dmap(x:indexed_dim(''1,''1),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st',line) - call dcl_uproc(parser,'_dmap(x:indexed_dim(''1,''1),n:block_seq)='//& - 'block_seq(n._lo+x._c,n._hi+x._c,n._st.n._b,n._align)',line) - call dcl_uproc(parser,'_dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)='//& - 'map_const($_dmap,x,n)',line) - call dcl_uproc(parser,'_dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)='//& - 's#map_const($_dmap,x,n)',line) - - call dcl_uproc(parser,'_drev(x:indexed_dim,n)=new indexed_dim {_m=x._d,_c=-x._c,_d=x._m,_n=n}',line) - call dcl_uproc(parser,'_drev(n,x:tuple(indexed_dim))=_drev(get_dim(x,n),n)',line) - call dcl_uproc(parser,'_drev(x:tuple(indexed_dim),y:tuple(fix int))=map_const($_drev,y,x)',line) - - call dcl_type(parser,'_round_up is unique',line) - call dcl_type(parser,'_round_down is unique',line) - call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:null)=null',line) - call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:int,r:_round_down)=(n*x._d-x._c)/x._m',line) - call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:int,r:_round_up)=(n*x._d+x._m-sign(1,x._m)-x._c)/x._m',line) - call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:tuple)=_dunmap(get_dim(n,x._n),x)',line) - call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:grid_slice_dim)='//& - 'min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up)',line) - call dcl_uproc(parser,& - '_dun(x:indexed_dim,m:range(int),n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m)))',line) - call dcl_uproc(parser,'_dun(x:int,m:range(int),n:extent)=n',line) - call dcl_uproc(parser,'_dunmap(x:tuple(indexed_dim or int),m:grid_slice or tuple(int),n:extent)='//& - '_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n)',line) - call dcl_uproc(parser,'_dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)='//& - '_dun(x.1,m.1,n)',line) - - ! Given tile and global region (which may be null) compute local region - call dcl_uproc(parser,'_local_region(t,r:null)=t',line) - call dcl_uproc(parser,'_local_region(t,r)=intersect(t,r)',line) - - call dcl_uproc(parser,'_root_node(at:''true)=_root_node()',line) - call dcl_uproc(parser,'_root_node(at:''false)=_this_node()',line) - - ! Resolve x[indexed] - call dcl_uproc(parser,& - '_get_dindex(&a,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& - 'tt=_correct(t,shapex._mshape);'//& - 'if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) {'//& - ' if at or a is <_comp^any> {'//& - ' _get_dindex_ss(&a,x,shapex,local_tile,local_region,tt,at);'//& - ' } else {'//& - ' _get_dindex_s(&a,x,shapex,local_tile,local_region,tt,at);'//& - ' }'//& - '} else {'//& - ' if at or a is <_comp^any> {'//& - ' _get_dindex_rs(&a,x,shapex,local_tile,local_region,tt,at);'//& - ' } else {'//& - ' _get_dindex_r(&a,x,shapex,local_tile,local_region,tt,at);'//& - ' }'//& - '}}',line) - - ! Resolve x[indexed] for cases where size(x[indexed])>=size(region) - ! -- in this case send one value for every point in current (sub)region - call dcl_uproc(parser,& - '_get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& - 'PM__head_node{'//& - ' shapexx=#shapex._mshape;'//& - ' this_tile=shapex._tile;'//& - ' foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& - ' if contains(#(shapex.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node(){'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& - ' portion_to_recv=overlap(local_tile,dest_range2);'//& - ' if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv)'//& - ' }}};'//& - ' dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - ' foreach p in nodes_for_grid(local_region.dist,dest_range){'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& - ' portion_to_recv=intersect(other_tile,dest_range);'//& - ' if size(portion_to_recv)>0: '//& - ' _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile)'//& - ' }}};'//& - ' _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& - ' _sync_messages(a,x)}}',line) - - ! Resolve x[indexed] for cases where size(x[indexed])<=size(region) - ! -- in this case send those values in x which are needed to calculate x[indexed] - call dcl_uproc(parser,& - '_get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& - 'shapexx=#shapex._mshape;'//& - 'src_range=_dmap(t,local_tile);var b=array(_arb(a),#src_range);'//& - 'foreach p in nodes_for_grid(shapex.dist,src_range) {'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' portion_to_send=overlap(src_range,other_tile);'//& - ' if size(portion_to_send)>0:_recv_slice(i,&b,portion_to_send);'//& - ' }}};'//& - ' dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - ' foreach p in nodes_for_grid(local_region.dist,dest_range){'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& - ' src_range2=_dmap(t,other_tile);'//& - ' portion_to_send=overlap(shapex._tile,src_range2);'//& - ' if size(portion_to_send)>0:_send_slice(i,x,portion_to_send);'//& - ' }}};'//& - ' u,v=overlap(src_range,shapex._tile);'//& - ' for i in u,j in v <>{_set_elem(&b,PM__getelem(x,j),i <>)};'//& - ' _sync_messages(x,b);'//& - '_copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t)}',line) - - ! Resolve x[indexed] for cases where size(x[indexed])>=size(region) - ! -- in this case send one value for every point in current (sub)region - ! -- Version for more complex types that need sync receive - call dcl_uproc(parser,& - '_get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& - 'shapexx=#shapex._mshape;'//& - 'this_tile=shapex._tile;'//& - 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'foreach p in nodes_for_grid(local_region.dist,dest_range){'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& - ' portion_to_recv=intersect(other_tile,dest_range);'//& - ' if size(portion_to_recv)>0: '//& - ' _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile)'//& - '}}};'//& - '_copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& - 'foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& - ' if contains(#(shapex.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& - ' portion_to_recv=overlap(local_tile,dest_range2);'//& - ' if size(portion_to_recv)>0 { '//& - ' _recv_slice_sync(i,&a,portion_to_recv);'//& - '}}}};_sync_messages(a,x)}',line) - - ! Resolve x[indexed] for cases where size(x[indexed])<=size(region) - ! -- in this case send those values in x which are needed to calculate x[indexed] - ! -- Version for more complex types that need sync receive - call dcl_uproc(parser,& - '_get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& - 'PM__head_node {'//& - 'shapexx=#shapex._mshape;'//& - 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'foreach p in nodes_for_grid(local_region.dist,dest_range){'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& - ' src_range=_dmap(t,other_tile);'//& - ' portion_to_send=overlap(shapex._tile,src_range);'//& - ' if size(portion_to_send)>0:_send_slice(i,x,portion_to_send);'//& - '}}}};'//& - 'src_range=_dmap(t,local_tile);var b=array(_arb(a),#src_range);'//& - 'if _head_node() or at { u,v=overlap(src_range,shapex._tile);'//& - ' for i in u,j in v <>{_set_elem(&b,PM__getelem(x,j),i <>)};'//& - ' foreach p in nodes_for_grid(shapex.dist,src_range) {'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' portion_to_send=overlap(src_range,other_tile);'//& - ' if size(portion_to_send)>0{ PM__head_node{_recv_slice_sync(i,&b,portion_to_send)};'//& - ' if at:_bcast_slice_shared(&b,#b,portion_to_send,''true)}'//& - ' }}}};'//& - ' _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t);'//& - ' _sync_messages(x,b)}',line) - - call dcl_uproc(parser,'_copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) {'//& - 'u=overlap(a_tile,_dunmap(t,b_tile,a_extent));'//& - 'for i in u <>{_set_elem(&a,PM__getelem(b,j),i <>) '//& - ' where j=b_tile#_dmap(t,a_tile[i])}}',line) - - call dcl_uproc(parser,'_copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) {'//& - 'u=intersect(a_tile,_dunmap(t,b_tile,a_extent));'//& - 'for i in u <>{ bb=_import_dref%(b);_set_elem(&a,_getref(bb,i),a_tile#i <>);'//& - '}}',line) - - ! Resolve x[ indexed ][ indexed or shared ] ... - call dcl_uproc(parser,& - '_get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:tuple(indexed_dim),at) {'//& - 't=_correct(tt,shapex._mshape);shapexx=#shapex._mshape;'//& - 'this_tile=shapex._tile;'//& - 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& - ' if contains(#(shapex.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node(){'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& - ' portion_to_recv=overlap(local_tile,dest_range2);'//& - ' if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv);'//& - '}}};'//& - 'nodes=nodes_for_grid(local_region.dist,dest_range);'//& - 'var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes);'//& - 'foreach pp in #nodes {'//& - ' p=nodes[pp];'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& - ' portion_to_recv=intersect(other_tile,dest_range);'//& - ' if size(portion_to_recv)>0 {'//& - ' b[pp]:={_getref(_import_dref%(x),h):h in portion_to_recv};'//& - ' _isend(i,b[pp]) }'//& - '}}};'//& - '_copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& - '_sync_messages(a,x)'//& - '}',line) - - - ! Resolve x[ indexed ][ indexed or shared ] ... - call dcl_uproc(parser,& - '_get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:tuple(indexed_dim),at) {'//& - 't=_correct(tt,shapex._mshape);shapexx=#shapex._mshape;'//& - 'this_tile=shapex._tile;'//& - 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'nodes=nodes_for_grid(local_region.dist,dest_range);'//& - 'var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes);'//& - ' foreach pp in #nodes {'//& - ' p=nodes[pp];'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& - ' portion_to_recv=intersect(other_tile,dest_range);'//& - ' if size(portion_to_recv)>0 {'//& - ' b[pp]:={_getref(_import_dref%(x),h):h in portion_to_recv};'//& - ' _isend(i,b[pp]) }'//& - '}}};'//& - '_copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& - 'foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& - ' if contains(#(shapex.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& - ' if i/=_this_node(){'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& - ' portion_to_recv=overlap(local_tile,dest_range2);'//& - ' if size(portion_to_recv)>0{ PM__head_node{ _recv_slice_sync(i,&a,portion_to_recv)};'//& - ' if at:_bcast_shared_slice(&a,#a,portion_to_recv,''true);}'//& - ' }};'//& - '};_sync_messages(a,x)}',line) - - ! Resolve x[ indexed ][ priv ] - call dcl_uproc(parser,& - '_get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:tuple(indexed_dim),complt,at) {'//& - 'dest_range=_dmap(t,this_tile,#shapex._mshape);'//& - ' foreach p in nodes_for_grid(shapex.dist,dest_range){'//& - ' i=index(dims(local_region.dist),p);'//& - ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& - ' _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt)'//& - '}};'//& - 'src_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'for j in overlap(this_tile,src_range) <>{'//& - ' jj=index(#this_tile,j);PM__do_at size(this_tile),jj,aa,a,xx,x { '//& - ' PM__assign(&aa,_getref(xx,null))}}; '//& - 'foreach p in nodes_for_grid(local_region.dist,src_range) {'//& - ' if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() {'//& - ' PM__recv_req pp,xx,x,_getref(xx,null)'//& - ' }};'//& - ' if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){'//& - ' i=index(dims(local_region.dist),p);'//& - ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& - ' _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt)'//& - ' }};'//& - ' _sync_messages(a,x);'//& - '}',line) - - ! Resolve x[ indexed ][ whatever ] = priv - call dcl_uproc(parser,& - '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:tuple(indexed_dim),'//& - ' pr:proc,complt,at) {'//& - 't=_correct(tt,shapex._mshape);dest_range=_dmap(t,this_tile,#shapex._mshape);'//& - 'PM__head_node{foreach p in nodes_for_grid(shapex.dist,dest_range){'//& - ' i=index(dims(shapex.dist),p);'//& - ' if contains(#(shapex.dist),p) and i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& - ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& - ' _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt)'//& - '}}};'//& - 'src_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'for j in overlap(this_tile,src_range) {'//& - ' jj=index(#this_tile,j);PM__do_at size(this_tile),jj,yy,y,xx,x { '//& - ' PM__assign(&^(_getlhs(xx,null)),yy,pr)}}; '//& - 'foreach p in nodes_for_grid(local_region.dist,src_range) {'//& - ' i=index(dims(shapex.dist),p);'//& - ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& - ' PM__recv_assn pp,xx,yy,x,y,at{PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}'//& - '}};'//& - '_sync_messages(x,y)}',line) - - !************************************************************** - ! Envelope and stencil definitions - !************************************************************** - - call dcl_type(parser,'envelope is rec{cross:extent or null,corner:extent or null,envelope:extent}',line) - call dcl_uproc(parser,'ortho(x:extent)=new envelope {cross=x,corner=spread(0..0,x),envelope=x}',line) - call dcl_uproc(parser,'ortho(x:extent,y:extent)='//& - 'new envelope {cross=x,corner=y,envelope=envelope(x,y)}',line) - call dcl_uproc(parser,'envelope(x:envelope)=x.envelope',line) - call dcl_uproc(parser,'envelope(x:extent)=x',line) - call dcl_uproc(parser,'envelope(x:any_int,y:any_int)='//& - 'min(xx,yy)..max(xx,yy) where xx=int(x),yy=int(y)',line) - call dcl_uproc(parser,'envelope(x:any_int,y:seq(any_int))=envelope(x..x,y)',line) - call dcl_uproc(parser,'envelope(x:seq(any_int),y:any_int)=envelope(x,y..y)',line) - call dcl_uproc(parser,'envelope(x:seq(any_int),y:seq(any_int))='//& - 'if(size(x)>0=>if(size(y)>0=>min(lx,ly)..max(hx,hy),lx..hx),if(size(y)>0=>0..0,ly..hy)) '//& - 'where lx=min(llx,hhx),ly=min(lly,hhy),hx=max(llx,hhx),hy=max(lly,hhy)'//& - 'where llx=int(low(x)),lly=int(low(y)),hhx=int(high(x)),hhy=int(high(y))',line) - call dcl_uproc(parser,'envelope(x:tuple,y:tuple)=map($envelope,x,y)',line) - call dcl_uproc(parser,'envelope(x:null,y:extent)=y',line) - call dcl_uproc(parser,'envelope(x:extent,y:null)=x',line) - call dcl_uproc(parser,'envelope(x:extent or null,y:envelope)=envelope(x,y.envelope)',line) - call dcl_uproc(parser,'envelope(x:envelope,y:extent or null)=envelope(x.envelope,y)',line) - call dcl_uproc(parser,'envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope)',line) - call dcl_uproc(parser,'string(x:envelope)=string(x.cross++" ortho "++x.corner)',line) - - !************************************************************** - ! Support for nhd statement - !************************************************************** - - call dcl_type(parser,'_nhd is rec{_nbhd,_tile,_tilesz,_bounds,_interior,_limits}',line) - call dcl_type(parser,'nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here}',line) - call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,y:invar boundary)<>='//& - 'new _nhd {_nbhd=x,_tile=t,_tilesz=#t,_bounds=y,_interior=overlap(t,region._tile),'//& - '_limits=region._extent} '//& - 'where t=_get_halo(region,region._tile,envelope(x))',line) - call dcl_uproc(parser,'PM__nhd%(x,y)='//& - '^(new _nhd {_nbhd=n,_tile=t,_tilesz=#t,_bounds=null,_interior=t,'//& - '_limits=region._extent},shared) '//& - 'where t=region._tile where n=xx '//& - 'where xx=spread(0..0,here){_check_nhd%(x)}',line) - - call dcl_uproc(parser,'_check_nhd%(n:invar envelope or extent) {}',line) - call dcl_uproc(parser,'_check_nhd%(n:extent):test "Neighbourhood must be invar"=>''false',line) - call dcl_uproc(parser,'_check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>''false',line) - call dcl_uproc(parser,'PM__check_bounds%(n,b:invar boundary){_check_ranks(n,b)}',line) - call dcl_uproc(parser,'PM__check_bounds%(n,b:boundary):test "Bounds must be ""invar"""=>''false',line) - call dcl_uproc(parser,'PM__check_bounds%(n,b):test "Bounds must have a boundary type"=>''false',line) - call dcl_uproc(parser,'_check_ranks(n:tuple,b:tuple):'//& - 'test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b))',line) - call dcl_uproc(parser,'_check_ranks(n:envelope,b:tuple):'//& - 'test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n.cross),rank(b))',line) - call dcl_uproc(parser,'_check_ranks(n,b:tuple):'//& - 'test "Rank of boundary does not match that of neighbourhood"=>same_type(''1,rank(b))',line) - call dcl_uproc(parser,'_check_ranks(n,b){}',line) - - call dcl_uproc(parser,'PM__set_nhd%(&n,x:complete){'//& - 'n._array[n._nbhd._interior[n._index]]:=x}',line) - call dcl_uproc(parser,'PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]:=x'//& - ' check "Expression in ""nhd"" must be ""complete"""=>''false',line) - - call dcl_uproc(parser,'PM__nhd_join(x)=x._array',line) - call dcl_uproc(parser,'PM__nhd_join(x,y)=new _join{head=x,tail=y._array}',line) - call dcl_uproc(parser,'PM__nhd_var%(x,n:_nhd,i,h)='//& - 'new nbhd{_array=_make_nhd(^(x,shared),n._tilesz <>),_nbhd=n,_index=i,_here=h}',line) - call dcl_uproc(parser,'_make_nhd(x,d){var v=array(x,d);return v}',line) - - call dcl_uproc(parser,'PM__set_edge%(&x,y,z){}',line) - - call dcl_uproc(parser,'PM__subref(x:nbhd,t:subs)=_nhd_sub(x,t)',line) - call dcl_uproc(parser,'PM__subref(x:nbhd,t:null)=_nhd_sub(x,t)',line) - - call dcl_uproc(parser,'_nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))='//& - 'PM__subref(x._array,tt+x._nbhd._interior[x._index])'//& - '{tt=_tup(t);'//& - 'test t++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),'//& - '"At "++x._here++" nhd "++t++" goes outside of boundary "++limits=>'//& - '_check_limits(dtt,limits,x._nbhd._bounds)'//& - 'where limits=x._nbhd._limits '//& - 'where dtt=tt+x._here}',line) - call dcl_uproc(parser,'_nhd_sub(x:nbhd,t)=_arb(x._array)'//& - 'check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>''false',line) - - call dcl_uproc(parser,'_check_limits(t:int,extent:range,bound:null)=t in extent',line) - call dcl_uproc(parser,'_check_limits(t:seq,extent:range,bound:null)=extent inc t',line) - call dcl_uproc(parser,'_check_limits(t,extent,bound)=''true',line) - call dcl_uproc(parser,'_check_limits(t:tuple,extent,bound:tuple)='//& - 'map_reduce($_check_limits,$and,t,extent,bound)',line) - call dcl_uproc(parser,'_check_limits(t:tuple(int),extent,bound:null)=t in extent',line) - call dcl_uproc(parser,'_check_limits(t:tuple,extent,bound:null)=extent inc t',line) - call dcl_uproc(parser,'_check_limits(t:tuple,extent,bound)=''true',line) - - call dcl_uproc(parser,'PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>''false',line) - - call dcl_uproc(parser,'envelope(x:_nhd)=envelope(x._nbhd)',line) - call dcl_uproc(parser,'envelope(x,y:_nhd)=envelope(x,y._nbhd)',line) - call dcl_uproc(parser,'envelope(x:_nhd,y:_nhd)=envelope(x._nbhd,y._nbhd)',line) - - call dcl_type(parser,'_join is struct^{head,tail}',line) - - call dcl_uproc(parser,'PM__blocking%(x:null){}',line) - call dcl_uproc(parser,'PM__blocking%(x):'//& - 'test "Block expression must be tuple of integers"=>''false',line) - call dcl_uproc(parser,'PM__blocking%(x:tuple(any_int)){'//& - 'test "Rank of ""block="" does not match region"=>same_type(rank(x),rank(region));'//& - 'test "Block sizes must be positive"=>map_reduce($_positive,$and,x)}',line) - call dcl_uproc(parser,'_positive(x)=x>0',line) - - call dcl_uproc(parser,& - 'PM__send_nhd%(&a:shared,nbhd:shared) <> { '//& - ' this_tile=region._tile;this_tile_x=nbhd._tile;'//& - ' pp=index2point(_this_node(),dims(region.dist));'//& - ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& - ' ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,region._extent,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,'//& - ' _foot(i-pp,nbhd._nbhd));'//& - ' ov=overlap(this_tile_x,other_tile);if size(ov)>0 {'//& - ' _recv_slice(p,&a,ov);'//& - ' }}'//& - ' };'//& - ' foreach ii in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& - ' i=pp*2-ii;ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,region._extent,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd));'//& - ' ov=overlap(this_tile_x,intersect(this_tile,other_tile_x));if size(ov)>0 {'//& - ' _send_slice(p,a,ov);'//& - ' }} '//& - ' }'//& - '}',line) - - call dcl_uproc(parser,'_exchange_cyclic_bounds(&a,nbhd,region,bound) {'//& - ' this_tile=region._tile;this_tile_x=nbhd._tile;'//& - ' pp=spread(0,this_tile);'//& - ' print("exchange");foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& - ' print("ww"++i);ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,region._extent,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,'//& - ' _foot(i-pp,nbhd._nbhd));print("CP"++i);'//& - ' ov=overlap(this_tile_x,other_tile);if size(ov)>0 {'//& - ' ov2=overlap(other_tile_x,intersect(other_tile,this_tile_x));'//& - ' print("copy"++ov2++"to"++ov);for k1 in ov,k2 in ov2:sync a[k1]:=v where v=a[k2]'//& - ' }}'//& - '}}',line) - call dcl_uproc(parser,& - '_exchange_cyclic_bounds(&a,nbhd,this_tile,bound:boundary except contains(CYCLE)) {}',line) - - call dcl_uproc(parser,'_foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner)',line) - call dcl_uproc(parser,'_foot(d,n:extent)=n',line) - - call dcl_uproc(parser,'PM__recv_nhd%(&a:shared,nbhd:shared) {}',line) - - call dcl_uproc(parser,& - 'PM__recv_nhd%(&a:shared _comp^any,nbhd:shared) <> { '//& - ' this_tile=region._tile;this_tile_x=nbhd._tile;'//& - ' pp=index2point(_this_node(),dims(region.dist));'//& - ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& - ' ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(_crss(i-pp),nbhd._nbhd));'//& - ' ov=overlap(this_tile_x,other_tile);if size(ov)>0 {'//& - ' _recv_slice_sync(p,&a,ov);'//& - ' }}'//& - ' }}',line) - - call dcl_uproc(parser,'_rev(a:tuple)=map($_rev,a)',line) - call dcl_uproc(parser,'_rev(a:range)=-high(a)..-low(a)',line) - - call dcl_uproc(parser,'_to_exchange(d,p,b:boundary_dim)=ok,pp'//& - ' where ok,pp=_to_exchange(d,p,spread(b,p))',line) - call dcl_uproc(parser,'_to_exchange(d,p,b)=ok,pp {'//& - 'var pp=0;dd=dims(d);var ok=_exchange_needed(dd,p,b);'//& - 'if ok {pp2=index(dd,p);pp:=index(dd,map($_mod_if_needed,p,dd,b));ok:=pp2/=_this_node()}}',line) - call dcl_uproc(parser,'_exchange_needed(d:tuple,p:tuple,b:tuple)='//& - 'map_reduce($_exchange_needed,$and,d,p,b)',line) - call dcl_uproc(parser,'_exchange_needed(d,p,b)='//& - 'p>=0 and p>"++q)}',line) - -!!$ '{print(_sys_node()++">>>"++p++";"++p mod size(d)++";"++size(s)++";"++'//& -!!$ '_get_elem(d,p mod ss)+_rdiv(p,ss)*size(s)) where ss=size(d)}',line) - - call dcl_uproc(parser,'_send_slice(p,a:_join,o) {_send_slice(p,a.head,o);_send_slice(p,a.tail,o)}',line) - call dcl_uproc(parser,'_recv_slice(p,&a:_join,o) {_recv_slice(p,&a.head,o);_recv_slice(p,&a.tail,o)}',line) - call dcl_uproc(parser,'_recv_slice_sync(p,&a:_join,o)'//& - '{_recv_slice_sync(p,&a.head,o);_recv_slice_sync(p,&a.tail,o)}',line) - call dcl_uproc(parser,'_sync_messages(x:_join):_sync_messages(x.head,x.tail)',line) - - call dcl_uproc(parser,'_not_zero(x)=if(x/=0=>1,0)',line) - call dcl_uproc(parser,'_crss(x)=1==map_reduce($_not_zero,$+,x)',line) - - call dcl_type(parser,'boundary is boundary_dim,tuple(boundary_dim)',line) - call dcl_type(parser,'boundary_dim is CYCLE,NO_EDGE,null',line) - call dcl_type(parser,'CYCLE is unique',line) - call dcl_type(parser,'NO_EDGE is unique',line) - - ! Add (anti) halo around tile - ! Args: mshape / tile / displacement - ! (mshape not used at the moment - there to cope with other topologies) - ! Result: expanded tile - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:range(int),i:any_int)='//& - 'low(t)+ii..high(t)+ii where ii=int(i)',line) - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:strided_range(int),i:any_int)='//& - ' low(t)+ii..high(t)+ii by step(t) where ii=int(i)',line) - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:block_seq,i:any_int){'//& - 'return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i)}',line) - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:map_seq,i:any_int) {'//& - 'var a=array(0,size(t));for j in a,k in t.array:j:=k+i;return new map_seq {array=a}}',line) - - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:range(int),i:range(any_int))='//& - 'low(t)+int(low(i))..high(t)+int(high(i))',line) - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:strided_range(int),i:range(any_int)){'//& - 'var step=step(t);var width=size(i);'//& - 'if width>step {step:=1;width:=1};'//& - 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0)}',line) - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:block_seq,i:range(any_int)){'//& - 'var step=step(t);var width=size(i)+width(t)-1;'//& - 'if width>step {step:=1;width:=1}'//& - 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0)}',line) - call dcl_uproc(parser,& - '_get_halo(d:range(int),t:map_seq,i:range(any_int)) {'//& - 'var a=array(0,[0..size(t)*size(i)-1]);var m=0;'//& - '_expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i));'//& - 'return _redim(a,shape(m))}',line) - call dcl_uproc(parser,& - '_get_halo(d:extent,j:grid,i:tuple(any_int or range(any_int)))='//& - ' map($_get_halo,d,j,i)',line) - call dcl_uproc(parser,& - '_get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))='//& - '_get_halo(d.1,t.1,i)',line) - - call dcl_uproc(parser,'_get_halo(d,t,i:null)=t',line) - - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:range(int),i:any_int)='//& - 'low(t)-ii..high(t)-ii where ii=int(i)',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:strided_range(int),i:any_int)='//& - ' low(t)-ii..high(t)-ii by step(t) where ii=int(i)',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:block_seq,i:any_int){'//& - 'return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i)}',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:map_seq,i:any_int) {'//& - 'var a=array(0,size(t));for j in a,k in t.array:j:=k-i;return new map_seq {array=a}}',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:range(int),i:range(any_int))='//& - 'low(t)-int(high(i))..high(t)-int(low(i))',line) - - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){'//& - 'var step=step(t);var width=size(i);'//& - 'if width>step {step:=1;width:=1}'//& - 'return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width)}',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){'//& - 'var step=step(t);var width=size(i)+width(t)-1;'//& - 'if width>step {step:=1;width:=1}'//& - 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width)}',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) {'//& - 'var a=array(0,[0..size(t)*size(i)-1]);var m=0;'//& - '_expand_aseq(&m,t.array,size(t.array),&a,-high(i),-low(i));'//& - 'return _redim(a,shape(m))}',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:extent,j:grid,'//& - ' i:tuple(any_int or range(any_int)))='//& - ' map($_get_anti_halo,d,j,i)',line) - call dcl_uproc(parser,& - '_get_anti_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))='//& - '_get_anti_halo(d.1,t.1,i)',line) - call dcl_uproc(parser,'_get_anti_halo(d,t,i:null)=t',line) - - - call dcl_uproc(parser,'_interior(d:range,t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n))',line) - call dcl_uproc(parser,'_interior(d:range,t:strided_range,n:range)=1..0 by 1',line) - call dcl_uproc(parser,'_interior(d:range,tt:block_seq,n:range)='//& - 'block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)'//& - 'where t=middle_blocks(tt)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:range,n:range,l:''true)='//& - 'low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:range,n:range,l:''false)='//& - 'low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t)',line) - call dcl_uproc(parser,'_get_chunk(d:range,tt:block_seq,n:range,l:''true)='//& - 'if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t))'//& - ' where t=middle_blocks(tt)',line) - call dcl_uproc(parser,'_get_chunk(d:range,tt:block_seq,n:range,l:''false)='//& - 'if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t))'//& - ' where t=middle_blocks(tt)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:grid_dim,n:range,l:_left or _right)=empty(t)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:block_seq,n:range,l:_left)='//& - 'block_seq(low(b),high(b),1,1,0) where b=first_block(t)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:block_seq,n:range,l:_right)='//& - 'block_seq(low(b),high(b),1,1,0) where b=last_block(t)',line) - - call dcl_uproc(parser,'_chunk(d,t,n,r,e,l)='//& - 'if(r_interior(d,t,n),r>e=>t,_get_chunk(d,t,n,l))',line) - call dcl_uproc(parser,'_get_chunk(d:tuple1d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple2d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple3d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple4d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple5d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l),_chunk(d.5,t.5,n.5,''5,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple6d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l),_chunk(d.5,t.5,n.5,''5,e,l),'//& - '_chunk(d.6,t.6,n.6,''6,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple7d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l),_chunk(d.5,t.5,n.5,''5,e,l),'//& - '_chunk(d.6,t.6,n.6,''6,e,l),_chunk(d.7,t.7,n.7,''7,e,l)]',line) - - call dcl_uproc(parser,'chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1',line) - call dcl_uproc(parser,'chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1',line) - call dcl_uproc(parser,'chunks(t:grid,n:extent)=2',line) - - call dcl_uproc(parser,'_cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n',line) - - call dcl_uproc(parser,'get_chunk(d:shape,t:tuple(range(any_int)),n:extent,i:int) {'//& - '_cr(i,rank(t)*2);const r;switch i {'//& - 'case 0: r=map($_interior,d,t,n);'//& - 'case 1: r=_get_chunk(d,t,n,''1,''true);'//& - 'case 2: r=_get_chunk(d,t,n,''1,''false);'//& - 'case 3: r=_get_chunk(d,t,n,''2,''true);'//& - 'case 4: r=_get_chunk(d,t,n,''2,''false);'//& - 'case 5: r=_get_chunk(d,t,n,''3,''true);'//& - 'case 6: r=_get_chunk(d,t,n,''3,''false);'//& - 'case 7: r=_get_chunk(d,t,n,''4,''true);'//& - 'case 8: r=_get_chunk(d,t,n,''4,''false);'//& - 'case 9: r=_get_chunk(d,t,n,''5,''true);'//& - 'case 10:r=_get_chunk(d,t,n,''5,''false);'//& - 'case 11:r=_get_chunk(d,t,n,''6,''true);'//& - 'case 12:r=_get_chunk(d,t,n,''6,''false);'//& - 'case 13:r=_get_chunk(d,t,n,''7,''true);'//& - 'case 14:r=_get_chunk(d,t,n,''7,''false);'//& - 'default:r=_get_chunk(d,t,n,''1,''true);'//& - '};return r}',line) - - call dcl_type(parser,'_left is unique',line) - call dcl_type(parser,'_right is unique',line) - - call dcl_uproc(parser,'get_chunk(d:shape,t:tuple(range(any_int) or block_seq),n:extent,i:int) {'//& - '_cr(i,rank(t)*4);const r;switch i {'//& - 'case 0:r=map($_interior,d,t,n);'//& - 'case 1:r=_get_chunk(d,t,n,''1,''true);'//& - 'case 2:r=_get_chunk(d,t,n,''1,''false);'//& - 'case 3:r=_get_chunk(d,t,n,''1,_left);'//& - 'case 4:r=_get_chunk(d,t,n,''1,_right);'//& - 'case 5:r=_get_chunk(d,t,n,''2,''true);'//& - 'case 6:r=_get_chunk(d,t,n,''2,''false);'//& - 'case 7:r=_get_chunk(d,t,n,''2,_left);'//& - 'case 8:r=_get_chunk(d,t,n,''2,_right);'//& - 'case 9:r=_get_chunk(d,t,n,''3,''true);'//& - 'case 10:r=_get_chunk(d,t,n,''3,''false);'//& - 'case 11:r=_get_chunk(d,t,n,''3,_left);'//& - 'case 12:r=_get_chunk(d,t,n,''3,_right);'//& - 'case 13:r=_get_chunk(d,t,n,''4,''true);'//& - 'case 14:r=_get_chunk(d,t,n,''4,''false);'//& - 'case 15:r=_get_chunk(d,t,n,''4,_left);'//& - 'case 16:r=_get_chunk(d,t,n,''4,_right);'//& - 'case 17:r=_get_chunk(d,t,n,''5,''true);'//& - 'case 18:r=_get_chunk(d,t,n,''5,''false);'//& - 'case 19:r=_get_chunk(d,t,n,''5,_left);'//& - 'case 20:r=_get_chunk(d,t,n,''5,_right);'//& - 'case 21:r=_get_chunk(d,t,n,''6,''true);'//& - 'case 22:r=_get_chunk(d,t,n,''6,''false);'//& - 'case 23:r=_get_chunk(d,t,n,''6,_left);'//& - 'case 24:r=_get_chunk(d,t,n,''6,_right);'//& - 'case 25:r=_get_chunk(d,t,n,''7,''true);'//& - 'case 26:r=_get_chunk(d,t,n,''7,''false);'//& - 'case 27:r=_get_chunk(d,t,n,''7,_left);'//& - 'case 28:r=_get_chunk(d,t,n,''7,_right);'//& - 'default:r=_get_chunk(d,t,n,''1,''true);'//& - '};return r}',line) - - call dcl_uproc(parser,'get_chunk(d:shape,t:grid,n:extent,i:int) {'//& - '_cr(i,1);const r;switch i {case 0:r=empty(#t);default:r=#t};return r}',line) - - ! ************************************************************* - ! nbr% and nbhd% intrinsics - ! ************************************************************* - - call dcl_type(parser,'disp_index is any_int,tuple(any_int)',line) - call dcl_type(parser,& - 'disp_sub is disp_index,tuple(any_int or range(any_int))',line) - - ! *** Default *** - call dcl_uproc(parser,'nbr%(x:chan,t:shared disp_index,v:shared){'//& - ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& - ' j=displace(region._mshape,here,t);'//& - ' var y=v;if contains(region._mshape,j) {y:=x@[j]};'//& - ' return y} ',line) - call dcl_uproc(parser,& - 'nbhd%(x:chan,t:shared disp_sub,v:shared) { '//& - ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& - ' var a=array(v,#t);'//& - ' foreach invar i in t {'//& - ' j=displace(region._mshape,here,i);'//& - ' if j in region._mshape {a[here]:=x@[j]}'//& - ' };return a}',line) - - ! *** Blocked distributions *** - call dcl_uproc(parser,& - 'nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) {'//& - ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& - ' var j=displace(region._mshape,here,t);'//& - ' a,ad=tile_with_halo%(x,t,v);'//& - ' return a[ad#j]}',& - line) - call dcl_uproc(parser,& - 'nbhd%(region:dshape(,blocked_distr),x:chan,t:shared disp_sub,v:shared){ '//& - ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& - ' a=displace(region._mshape,here,t);'//& - ' y,yd=tile_with_halo%(x,t,v);'//& - ' return y[yd#a]'//& - '} ',& - line) - - call dcl_uproc(parser,'tile_with_halo%(x,t,v) {return a,d '//& - 'where a,d=_local_tile_with_halo(region,PM__local(x),t,v)}',line) - - ! Return local tile with halo cells - call dcl_uproc(parser,& - '_local_tile_with_halo(region,x,t,v) { '//& - ' this_tile_x=_get_halo(region._mshape,region._tile,t);'//& - ' var a=array(v,#this_tile_x);'//& - ' foreach i in nodes_for_grid(region.dist,this_tile_x) {'//& - ' other_tile=_get_elem(region.dist,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& - ' var p=index(dims(region.dist),i);'//& - ' if contains(#region.dist,i) and p/=_this_node() {'//& - ' _recv_slice(p,&a,overlap(this_tile_x,other_tile));'//& - ' } '//& - ' };'//& - ' foreach i in '//& - ' nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) {'//& - ' other_tile=_get_elem(region.dist,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& - ' p=index(dims(region.dist),i);'//& - ' if contains(#region.dist,i) and p/=_this_node() {'//& - ' _send_slice(p,x,overlap(region._tile,other_tile_x));'//& - ' } '//& - ' };'//& - ' o,oo=overlap(this_tile_x,region._tile);a[o]:=x[oo];'//& - ' _sync_messages(a,x);return a,this_tile_x }',line) - - call dcl_uproc(parser,& - '_local_tile_with_halo(region,x:_comp,t,v) { '//& - ' this_tile_x=_get_halo(region._mshape,region._tile,t);'//& - ' var a=array(v,#this_tile_x);'//& - ' foreach i in '//& - ' nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) {'//& - ' other_tile=_get_elem(region.dist,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& - ' p=index(dims(region.dist),i);'//& - ' if contains(#region.dist,i) and p/=_this_node() {'//& - ' _send_slice(p,x,overlap(region._tile,other_tile_x));'//& - ' } '//& - ' };'//& - ' o,oo=overlap(this_tile_x,region._tile);a[o]:=x[oo];'//& - ' foreach i in nodes_for_grid(region.dist,this_tile_x) {'//& - ' other_tile=_get_elem(region.dist,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& - ' p=index(dims(region.dist),i);'//& - ' if contains(dims(region.dist),i) and p/=_this_node() {'//& - ' _recv_slice_sync(p,&a,overlap(this_tile_x,other_tile));'//& - ' } '//& - ' };'//& - ' _sync_messages(a,x);return a,this_tile_x }',line) - - ! Displace x by y within mshape d - call dcl_uproc(parser,'displace(d:range(int),x:int,y:any_int)='//& - 'x+int(y)',line) - call dcl_uproc(parser,'displace(d:range(int),x:int,y:range(any_int))='//& - 'x+int(y._lo)..x+int(y._hi)',line) - call dcl_uproc(parser,'displace(d:extent1d,x:tuple1d(int),y:range(any_int) or any_int)='//& - 'displace(d.1,x.1,y)',line) - call dcl_uproc(parser,'displace(d:extent,'//& - 'x:tuple(int),y:tuple(range(any_int) or any_int))='//& - 'map($displace,d,x,y)',line) - - - !************************************************ - ! TOPOLOGIES - !************************************************ - - call dcl_proc(parser,'_get_dims(int,int)->int',op_get_dims,0,& - line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int)->int,int',& - op_get_dims,0,& - line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int)->int,int,int',& - op_get_dims,0,& - line,proc_is_impure) - call dcl_proc(parser,& - '_get_dims(int,int,int,int,int)->int,int,int,int',& - op_get_dims,0,& - line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->'//& - 'int,int,int,int,int',& - op_get_dims,0,& - line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int',& - op_get_dims,0,& - line,proc_is_impure) - call dcl_proc(parser,& - '_get_dims(int,int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int,int',& - op_get_dims,0,& - line,proc_is_impure) - - call dcl_uproc(parser,'_zd(x,y:null)=1',line) - call dcl_uproc(parser,'_zd(x,y)=if(x==1=>1,0)',line) - call dcl_uproc(parser,& - 'cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,dd,n)',line) - call dcl_uproc(parser,& - 'cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n)',line) - call dcl_uproc(parser,& - 'cart_topo(d:tuple1d,t:tuple1d,n:int)='//& - 'tuple(_get_dims(n,_zd(d.1,t.1)))',line) - call dcl_uproc(parser,'cart_topo(d:tuple2d,t:tuple2d,n:int)=tuple(b,a) '//& - 'where a,b=_get_dims(n,_zd(d.2,t.2),_zd(d.1,t.1))',line) - call dcl_uproc(parser,'cart_topo(d:tuple3d,t:tuple3d,n:int)=tuple(c,b,a) '//& - 'where a,b,c=_get_dims(n,_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) - call dcl_uproc(parser,'cart_topo(d:tuple4d,t:tuple4d,n:int)=tuple(dd,c,b,a) '//& - 'where a,b,c,dd=_get_dims(n,_zd(d.4,t.4),_zd(d.3,t.3),'//& - '_zd(d.2,t.2),_zd(d.1,t.1))',line) - call dcl_uproc(parser,'cart_topo(d:tuple5d,t:tuple5d,n:int)=tuple(e,dd,c,b,a) '//& - 'where a,b,c,dd,e=_get_dims(n,_zd(d.5,t.5),_zd(d.4,t.4),'//& - '_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) - call dcl_uproc(parser,'cart_topo(d:tuple6d,t:tuple6d,n:int)=tuple(f,e,dd,c,b,a) '//& - 'where a,b,c,dd,e,f=_get_dims(n,_zd(d.6,t.6),_zd(d.5,t.5),'//& - '_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) - call dcl_uproc(parser,'cart_topo(d:tuple7d,t:tuple7d,n:int)=tuple(g,f,e,dd,c,b,a) '//& - 'where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),'//& - '_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) - - ! ************************************************ - ! DISTRIBUTIONS - ! ************************************************ - call dcl_type(parser,& - 'distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr',line) - call dcl_type(parser,'distr:indexable is null,blocked_distr,distr_dim,tuple(distr_dim)',line) - call dcl_type(parser,'blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr)',line) - - ! Null distribution (mirroring) - call dcl_type(parser,'no_distr is rec {_hi:int,_p:int}',line) - - call dcl_uproc(parser,& - 'no_distr(g:int,d:int)='//& - 'new no_distr {_hi=int(g),_p=int(d)}',line) - call dcl_uproc(parser,'#(b:no_distr)=shape([0..b._p-1])',line) - call dcl_uproc(parser,'_shp(b:no_distr)=0..b._p-1',line) - call dcl_uproc(parser,'dims(b:no_distr)=[b._p]',line) - call dcl_uproc(parser,'size(b:no_distr)=b._p',line) - call dcl_uproc(parser,& - '_get_elem(b:no_distr,i:int)=0..b._hi-1',line) - call dcl_uproc(parser,& - 'tile_size(b:no_distr,i:int)=b._hi',line) - call dcl_uproc(parser,'empty(b:no_distr)=1..0',line) - call dcl_uproc(parser,'nodes_for_grid(b:no_distr,g:seq(int))='//& - '0..0',line) - call dcl_uproc(parser,'node_for(b:no_distr,j:int)=0',line) - call dcl_uproc(parser,'index(b:no_distr,j:int,p:int)=j',line) - call dcl_uproc(parser,'node_nhd(b:no_distr,p:int,d:range(int))=0..0',line) - - ! Direct distribution (1-1 map to processor topology) - call dcl_type(parser,'direct_distr is rec {_p:int}',line) - call dcl_uproc(parser,& - 'direct_distr(d:int)=new direct_distr {_p=int(d)}',line) - call dcl_uproc(parser,'#(b:direct_distr)=shape([0..b._p-1])',line) - call dcl_uproc(parser,'_shp(b:direct_distr)=0..b._p-1',line) - call dcl_uproc(parser,'dims(b:direct_distr)=[b._p]',line) - call dcl_uproc(parser,'size(b:direct_distr)=b._p',line) - call dcl_uproc(parser,& - '_get_elem(b:direct_distr,i:int)=''0..''0',line) - call dcl_uproc(parser,& - 'tile_size(b:direct_distr,i:int)=''1',line) - call dcl_uproc(parser,'empty(b:direct_distr)=''1..''0',line) - call dcl_uproc(parser,'nodes_for_grid(b:direct_distr,g:seq(int))='//& - 'int(g)',line) - call dcl_uproc(parser,'node_for(b:direct_distr,j:int)=j',line) - call dcl_uproc(parser,'index(b:direct_distr,j:int,p:int)=''0',line) - call dcl_uproc(parser,'node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p',line) - call dcl_uproc(parser,'node_co_nhd(b:direct_distr,p:int,d:int or range(int))='//& - '-high(d)+p..-low(d)+p by -1',line) - - ! Variable block distribution - call dcl_type(parser,'vblock_distr is rec {_hi:int,_p:int}',line) - call dcl_uproc(parser,& - 'vblock_distr(g:int,d:int)='//& - 'new vblock_distr {_hi=int(g),_p=int(d)}',line) - call dcl_uproc(parser,'#(b:vblock_distr)=shape([0..b._p-1])',line) - call dcl_uproc(parser,'_shp(b:vblock_distr)=0..b._p-1',line) - call dcl_uproc(parser,'dims(b:vblock_distr)=[b._p]',line) - call dcl_uproc(parser,'size(b:vblock_distr)=b._p',line) - call dcl_uproc(parser,& - '_get_elem(b:vblock_distr,i:int)=start..finish'//& - ' where finish=(ii+1)*b._hi/b._p-1'//& - ' where start=ii*b._hi/b._p where ii=int(i)',line) - call dcl_uproc(parser,& - 'tile_size(b:vblock_distr,i:int)=finish-start+1'//& - ' where finish=(ii+1)*b._hi/b._p-1'//& - ' where start=ii*b._hi/b._p where ii=int(i)',line) - call dcl_uproc(parser,'empty(b:vblock_distr)=1..0',line) - call dcl_uproc(parser,'nodes_for_grid(b:vblock_distr,g:seq(int))='//& - 'lo1..hi1 where'//& - ' lo1=_rdiv(b._p*(int(low(g))+1)-1,b._hi),'//& - ' hi1=_rdiv(b._p*(int(high(g))+1)-1,b._hi)',line) - call dcl_uproc(parser,'node_for(b:vblock_distr,j:int)=p'//& - ' where p=_rdiv(b._p*(jj+1)-1,b._hi) where jj=int(j)',line) - call dcl_uproc(parser,'index(b:vblock_distr,j:int,p:int)=i'//& - ' where i=jj-s1'//& - ' where s1=p*b._hi/b._p'//& - ' where jj=int(j)',line) - call dcl_uproc(parser,'_rdiv(x,y)=if(x>0=>x/y,(x-y+1)/y)',line) - call dcl_uproc(parser,'node_nhd(b:vblock_distr,p:int,d:range(int))='//& - 'node_for(b,low(r)+low(d))..node_for(b,high(r)+high(d))'//& - ' where r=_get_elem(b,p)',line) - call dcl_uproc(parser,'node_co_nhd(b:vblock_distr,p:int,d:range(int))='//& - 'node_for(b,high(r)-low(d))..node_for(b,low(r)-high(d)) by -1'//& - ' where r=_get_elem(b,p)',line) - - ! fixed block distribution - call dcl_type(parser,'block_distr is rec {_b:int,_s:int,_p:int}',line) - call dcl_uproc(parser,& - 'block_distr(s:int,t:int,b:int)='//& - 'new block_distr {_b=b,_s=s,_p=p} where p=(s+b-1)/b',line) - call dcl_uproc(parser,'#(b:block_distr)=shape([0..b._p-1])',line) - call dcl_uproc(parser,'_shp(b:block_distr)=0..b._p-1',line) - call dcl_uproc(parser,'dims(b:block_distr)=[b._p]',line) - call dcl_uproc(parser,'size(b:block_distr)=b._p',line) - call dcl_uproc(parser,& - '_get_elem(b:block_distr,i:int)=start..finish'//& - ' where finish=min(b._s-1,(ii+1)*b._b-1)'//& - ' where start=ii*b._b where ii=int(i)',line) - call dcl_uproc(parser,& - 'tile_size(b:block_distr,i:int)=finish-start+1'//& - ' where finish=min(b._s-1,(ii+1)*b._b-1)'//& - ' where start=ii*b._b where ii=int(i)',line) - call dcl_uproc(parser,& - 'empty(b:block_distr)=1..0',line) - call dcl_uproc(parser,'nodes_for_grid(b:block_distr,g:seq(int))='//& - 'lo1..hi1 where'//& - ' lo1=_rdiv(int(low(g)),b._b),'//& - ' hi1=_rdiv(int(high(g)),b._b)',line) - call dcl_uproc(parser,'node_for(b:block_distr,j:int)=p'//& - ' where p=_rdiv(jj,b._b) where jj=int(j)',line) - call dcl_uproc(parser,'index(b:block_distr,j:int,p:int)=i'//& - ' where i=jj-s1'//& - ' where s1=p*b._b'//& - ' where jj=int(j)',line) - call dcl_uproc(parser,'node_nhd(b:block_distr,p:int,d:range(int))='//& - 'p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b',line) - call dcl_uproc(parser,'node_co_nhd(b:block_distr,p:int,d:range(int))='//& - 'p+(-low(d)+b._b-1)/b._b..p+(-high(d)-b._b+1)/b._b by -1',line) - - ! Cyclic distribution - call dcl_type(parser,'cyclic_distr is rec {_hi:int,_p:int}',line) - call dcl_uproc(parser,& - 'cyclic_distr(g:int,d:int)='//& - 'new cyclic_distr {_hi=int(g),_p=int(d)}',line) - call dcl_uproc(parser,'#(b:cyclic_distr)=shape([0..b._p-1])',line) - call dcl_uproc(parser,'_shp(b:cyclic_distr)=0..b._p-1',line) - call dcl_uproc(parser,'dims(b:cyclic_distr)=[b._p]',line) - call dcl_uproc(parser,'size(b:cyclic_distr)=b._p',line) - call dcl_uproc(parser,& - '_get_elem(b:cyclic_distr,i:int)='//& - ' int(i)..b._hi-1 by b._p',line) - call dcl_uproc(parser,& - 'tile_size(b:cyclic_distr,i:int)='//& - '(b._hi-1-int(i))/b._p+1',line) - call dcl_uproc(parser,& - 'empty(b:cyclic_distr)=1..0 by 1',line) - call dcl_uproc(parser,'_cyx(p,low,high){'//& - ' var lo=0;var hi=p-1;'//& - ' if high-low

lo2 {lo:=lo2;hi:=hi2}'//& - ' };'//& - 'return lo,hi}',line) - call dcl_uproc(parser,'nodes_for_grid(b:cyclic_distr,g:seq(int))='//& - 'lo1..hi1 '//& - ' where lo1,hi1=_cyx(b._p,int(low(g)),int(high(g)))',& - line) - call dcl_uproc(parser,'node_for(b:cyclic_distr,j:any_int)=p'//& - ' where p=int(j) mod b._p',line) - call dcl_uproc(parser,'index(b:cyclic_distr,j:int,p:int)=int(j)/b._p',line) - call dcl_uproc(parser,'node_nhd(b:cyclic_distr,p:int,d:range(int))='//& - 'p+low(d)..p+high(d)',line) - call dcl_uproc(parser,'node_co_nhd(b:cyclic_distr,p:int,d:range(int))='//& - 'p-low(d)..p-high(d) by -1',line) - - ! Block cyclic distribution - call dcl_type(parser,& - 'block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int}',line) - call dcl_uproc(parser,& - 'block_cyclic_distr(g:int,p:int,b:int)='//& - 'new block_cyclic_distr {_hi=int(g),_p=int(p),_b=int(b),'//& - ' _s=s}'//& - ' where s=p*b',line) - call dcl_uproc(parser,'#(b:block_cyclic_distr)=shape([0..b._p-1])',line) - call dcl_uproc(parser,'_shp(b:block_cyclic_distr)=0..b._p-1',line) - call dcl_uproc(parser,'dims(b:block_cyclic_distr)=[b._p]',line) - call dcl_uproc(parser,'size(b:block_cyclic_distr)=b._p',line) - call dcl_uproc(parser,& - '_get_elem(b:block_cyclic_distr,i:int)='//& - ' block_seq(s,b._hi-1,b._s,b._b,0)'//& - ' where s=ii*b._b where ii=int(i)',& - line) - call dcl_uproc(parser,& - 'tile_size(b:block_cyclic_distr,i:int)='//& - 'nc*b._b+max(0,min(b._b,df-nc*b._s)) where nc=df/b._s where df=b._hi-s'//& - ' where s=ii*b._b where ii=int(i)',& - line) - call dcl_uproc(parser,& - 'empty(b:block_cyclic_distr)=block_seq(1,0,1,1)',line) - call dcl_uproc(parser,'_cybx(b,p,low,high) {'//& - ' var lo=0;var hi=p;'//& - ' if high-lowlo2 {lo:=lo2;hi:=hi2};'//& - ' }; '//& - ' return lo,hi}',line) - call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:seq(int))='//& - 'lo1..hi1 '//& - ' where lo1,hi1=_cybx(b._b,b._p,int(low(g)),int(high(g)))',& - line) - call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:block_seq){'//& - ' var r=0..b._p;'//& - ' if b._s==step(g) {r:=nodes_for_grid(b,low(g)..low(g)+width(g)-1)};return r}',line) - call dcl_uproc(parser,'node_for(b:block_cyclic_distr,j:int)=p'//& - ' where p=_rdiv(jj,b._b) mod b._p where jj=int(j)',line) - call dcl_uproc(parser,'index(b:block_cyclic_distr,j:int,p:int)=i'//& - ' where i=r+b._b*(s-p)'//& - ' where r=j-s*b._s'//& - ' where s=_rdiv(j,b._s)',line) - call dcl_uproc(parser,'node_nhd(b:block_cyclic_distr,p:int,d:range(int))='//& - 'p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b',line) - call dcl_uproc(parser,'node_co_nhd(b:block_cyclic_distr,p:int,d:range(int))='//& - 'p+(-low(d)+b._b-1)/b._b..p+(-high(d)-b._b+1)/b._b by -1',line) - - - ! Tuple of distributions - call dcl_uproc(parser,'node_for(b:tuple(distr_dim),j:tuple(int))='//& - 'map($node_for,b,j)',line) - call dcl_uproc(parser,'#(b:tuple(distr_dim))=shape(map($_shp,b))',line) - call dcl_uproc(parser,'dims(b:tuple(distr_dim))=map($size,b)',line) - call dcl_uproc(parser,'_get_elem(b:tuple(distr_dim),i:tuple(int))'//& - '=map($_get_elem,b,i)',line) - call dcl_uproc(parser,'_get_elem(b:tuple(distr_dim),i:int)='//& - '_get_elem(b,index2point(i,dims(b)))',line) - call dcl_uproc(parser,'tile_size(b:tuple(distr_dim),i:tuple(int))'//& - '=map($tile_size,b,i)',line) - call dcl_uproc(parser,'empty(b:tuple(distr_dim))=map($empty,b)',line) - call dcl_uproc(parser,'nodes_for_grid(b:tuple(distr_dim),g:grid)'//& - '=map($nodes_for_grid,b,g)',line) - call dcl_uproc(parser,'node_num_for(b:tuple(distr_dim),j:tuple(int))'//& - '=index(dims(b),map($node_for,b,j))',line) - call dcl_uproc(parser,'index(b:tuple(distr_dim),j:tuple(int),p:tuple(int))'//& - '=index(tile_size(b,p),map($index,b,j,p))',line) - call dcl_uproc(parser,'node_and_index(b:tuple(distr_dim),j:tuple(int))'//& - '=index(dims(b),p),i where i=index(tile_size(b,p),map($index,b,j,p)) '//& - ' where p=map($node_for,b,j)',line) - call dcl_uproc(parser,'node_and_index(b:distr_dim,j:int)=p,i '//& - 'where i=index(b,j,p) where p=node_for(b,j)',line) - call dcl_uproc(parser,'node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d)',line) - call dcl_uproc(parser,'node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d)',line) - - ! ***************************************** - ! SUPPORT FOR PARALLEL STATEMENTS - ! ***************************************** - - ! Get and set elements in "for" - call dcl_uproc(parser,'PM__getelem(x:grid_slice_dim,y)=_get_elem(x,y)',line) - call dcl_uproc(parser,'PM__getelem(x:grid_slice,y)=_get_elem(x,y)',line) - call dcl_uproc(parser,'PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t))',line) - call dcl_uproc(parser,'PM__getelem(a:array_slice(any^any,),y)=_get_elem(a,y)',line) - call dcl_uproc(parser,'PM__getelem(x:array_template,y)=x._a',line) -!!$ call dcl_uproc(parser,'PM__getelem(a:any^dshape,t)=_get_aelem(a,i) '//& -!!$ 'check p==_this_node() where p,i=node_and_index(_shape(a).dist,_tup(t))',line) - call dcl_uproc(parser,'PM__getelem(a:any^dshape,t)=_get_elem(a,(#a)[t])',line) - - call dcl_uproc(parser,'PM__setelem(&x,v,y) {_set_elem(&x,v,(#x)[y])}',line) - call dcl_uproc(parser,'PM__setelem(&a:any^mshape,v,t:index)'//& - '{ PM__setaelem(&a,index(dims(a),t),v) }',line) - call dcl_uproc(parser,'PM__setelem(&a:any^dshape,v,t:index) {'//& - ' PM__setaelem(&a,i,v) check p==_this_node() '//& - ' where p,i=node_and_index((#a).dist,_tup(t)) }',line) - call dcl_uproc(parser,'PM__setelem(&a:array_slice(any^any,),v,t:index) {'//& - ' _set_elem(&a._a,v,a._s[t]) }',line) - - call dcl_uproc(parser,'PM__get_elem%(x:shared,i,h)=PM__getelem(x,h)',line) - call dcl_uproc(parser,'PM__set_elem%(&x:shared,v:complete,i,h)'//& - '{PM__setelem(&x,v,h <>);_assemble(&x,region <>)}',line) - - call dcl_uproc(parser,'PM__get_elem%(x:shared any^dshape,i,h)='//& - '_get_elem(PM__local(x),i)',line) - call dcl_uproc(parser,'PM__set_elem%(&x:shared any^dshape,v:complete,i,h) '//& - '{_set_elem(&x,v,i <>)}',line) - - call dcl_uproc(parser,'_assemble(&a:any^mshape,region:mshape) {}',line) - - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region:mshape) {}',line) - - call dcl_uproc(parser,'_assemble(&a:any^mshape,region) {'//& - ' dist=region.dist; '//& - ' foreach p in #(dist) {'//& - ' tile=dist[p];'//& - ' i=index(dims(dist),p);'//& - ' if i==_this_node() {'//& - ' for j in tile <>{ '//& - ' var k=PM__getelem(a,j); '//& - ' PM__broadcast(&k,i)'//& - ' };'//& - ' } else { '//& - ' for j in tile <>{ '//& - ' var k=_arb(a);'//& - ' PM__broadcast(&k,i);'//& - ' PM__setelem(&a,k,j <>)'//& - ' }'//& - ' }'//& - ' } }',& - line) - - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region) {'//& - ' dist=region.dist; '//& - ' foreach p in #(dist) {'//& - ' tile=intersect((#(a._a))#a._s,dist[p]);'//& - ' i=index(dims(dist),p);'//& - ' if i==_this_node() {'//& - ' for j in tile <>{ '//& - ' var k=PM__getelem(a._a,j); '//& - ' PM__broadcast(&k,i)'//& - ' };'//& - ' } else { '//& - ' for j in tile <>{ '//& - ' var k=_arb(a._a);'//& - ' PM__broadcast(&k,i);'//& - ' PM__setelem(&a._a,k,j <>)'//& - ' }'//& - ' }'//& - ' } }',& - line) - - ! Support for % procs - call dcl_uproc(parser,'PM__get_tilesz(d)=d._tile,d._size',line) - call dcl_uproc(parser,'PM__get_tilesz(d:mshape)=d,size(d)',line) - - ! Support for @ operator - if(pm_is_compiling) then - call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region,size(region))',line) - call dcl_uproc(parser,& - 'PM__makearray%(x:priv)=_makearray(x,region,size(region))'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) - call dcl_uproc(parser,& - 'PM__makearray%(x:invar)=_makearray(x,region,size(region))'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) - call dcl_proc(parser,& - '_makearray(x:any,y:any,z:any)->PM__invar_dim x,y',& - op_make_array,0,line,proc_needs_type) - else - call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region)',line) - call dcl_uproc(parser,& - 'PM__makearray%(x:priv)=_makearray(x,region)'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) - call dcl_uproc(parser,& - 'PM__makearray%(x:invar)=_makearray(x,region)'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) - call dcl_proc(parser,& - '_makearray(x:any,y:any)->PM__dim x,y',& - op_make_array,0,line,proc_needs_type) -!!$ call dcl_uproc(parser,'PM__correctarray(x)=_redim(PM__export - endif - - ! active%() intrinsic - call dcl_uproc(parser,'active%(x)=masked(^(x,coherent),^(^??,coherent) <>)',line) - call dcl_uproc(parser,'active%()=^(^??,coherent)',line) - call dcl_proc(parser,'PM__active()->bool',op_active,0,line,0) - - ! Imports and exports - call dcl_proc(parser,'_import_val(x:any)->=x',& - op_import_val,0,line,0) - call dcl_proc(parser,'PM__importshrd(x:any)->=x',& - op_import_val,0,line,0) - call dcl_proc(parser,'PM__importvarg(x:any)->=x',& - op_import_varg,0,line,proc_is_not_inlinable) - call dcl_proc(parser,'_import_scalar(x:any)->invar x',& - op_import_scalar,0,line,0) - call dcl_uproc(parser,'PM__import_val(x) {PM__checkimp(x);return _import_val(x)}',line) - call dcl_uproc(parser,'PM__impscalar(x) {PM__checkimp(x);return _import_scalar(x)}',line) - call dcl_uproc(parser,'PM__import_val(x:^*(,,,,)) {'//& - 'test "Compiler internal error:importing reference" => ''false;return x}',line) - call dcl_uproc(parser,'PM__impscalar(x:^*(,,,,)) {'//& - 'test "Compiler internal error:importing reference" => ''false;return x}',line) - - call dcl_uproc(parser,'PM__checkimp(x,arg...) {PM__checkimp(x);PM__checkimp(arg...)}',line) - call dcl_uproc(parser,'PM__checkimp(x) {}',line) - call dcl_uproc(parser,'PM__checkimp(x:contains(PM__distr_tag)) {'//& - 'test "Cannot import a distributed value into a nested parallel scope" => ''false}',& - line) - - call dcl_type(parser,'schedule(subregion,blocking) is '//& - 'rec{_subregion:subregion,_subtile,_blocking:blocking}',line) - call dcl_uproc(parser,'subregion(schedule:schedule)=schedule._subregion',line) - call dcl_uproc(parser,'subregion(schedule:null)=null',line) - call dcl_uproc(parser,'subtile(schedule:schedule)=schedule._subtile',line) - - ! Over statements - call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar)<>='//& - 'new schedule{_subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region)}',line) - call dcl_uproc(parser,'PM__over%(x:invar,block:invar)<>='//& - 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& - 'where s=intersect(x,schedule._subregion)',line) - call dcl_uproc(parser,'PM__make_over%(schedule:null,'//& - 'x:invar tuple(subs_dim except stretch_dim),block:invar)<>='//& - 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& - 'check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s '//& - 'where s=fill_in(region._extent,x)',line) - call dcl_uproc(parser,'PM__make_over%(x:invar tuple(subs_dim except stretch_dim)'//& - ',block:invar)<>='//& - 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& - 'where s=intersect(map($norm,fill_in(region._extent,x)),schedule._subregion)',line) - call dcl_uproc(parser,'PM__make_over%(x:invar,block)=x'//& - ' check "Expression in an ""over"" statement must be a subscript tuple"=>''false',line) - call dcl_uproc(parser,'PM__make_over%(x,block)=x'//& - ' check "Expression in an ""over"" statement must be ""invar"""=>''false',line) - - call dcl_uproc(parser,'_blocking(b:tuple(any_int),region)=int(b) {'//& - 'test "Blocking factor must have same rank as current region"=>'//& - ' rank(b)==rank(extent(region))}',& - line) - call dcl_uproc(parser,'_blocking(b,region)=null {'//& - 'test "Blocking factor must be a tuple of integers"=>''false}',line) - call dcl_uproc(parser,'_blocking(b:null,region)=null',line) - - - if(.not.pm_is_compiling) then - call dcl_uproc(parser,'PM__do_over%(x:null)=true',line) - call dcl_uproc(parser,'PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion',line) - call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) - call dcl_uproc(parser,'PM__do_over%(x:invar grid) <>'//& - '{chan var t=false;'//& - ' _in(x,&^(PM__local(^(&t@))) <>);'//& - ' return t}',line) - call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) - call dcl_uproc(parser,'_in(x,&t){for i in x <>{sync t[i]:=true}}',line) - else - call dcl_uproc(parser,'PM__do_over(x:null,region)=x',line) - call dcl_uproc(parser,'PM__do_over(x:schedule,region)='//& - '_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking)',line) - call dcl_uproc(parser,'_do_elem(x:range(int))=_st(low(x),high(x))',line) - call dcl_uproc(parser,'_do_elem(x:strided_range(int))=_st(low(x),high(x),step(x))',line) - call dcl_uproc(parser,'_do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x))',line) - call dcl_uproc(parser,'_do_elem(x:map_seq)=x.array',line) - call dcl_uproc(parser,'_do_elem(x:single_point)=_st(x._t)',line) - call dcl_uproc(parser,'PM__nested_loop(x:null){}',line) - call dcl_proc(parser,'PM__nested_loop(any)',op_nested_loop,0,line,0) - call dcl_uproc(parser,'_ldims(x:mshape)=map_apply($size,$_st,x._extent)',line) - call dcl_uproc(parser,'_ldims(x:dshape)=map_apply($size,$_st,x._tile)',line) - endif - - ! Parallel processing inquiry - call dcl_proc(parser,'_sys_node()->int',op_sys_node,0,line,0) - call dcl_proc(parser,'sys_nnode()->int',op_sys_nnode,0,line,0) - call dcl_proc(parser,'_this_node()->int',op_this_node,1,line,0) - call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->int',op_this_node,2,line,0) - call dcl_proc(parser,'this_nnode()->int',op_this_nnode,0,line,0) - call dcl_proc(parser,'_shrd_node()->int',op_shared_node,0,line,0) - call dcl_proc(parser,'shrd_nnode()->int',op_shared_nnode,0,line,0) - call dcl_proc(parser,'_root_node()->int',op_root_node,0,line,0) - call dcl_proc(parser,'is_shrd()->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_shrd(any)->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_par()->bool',op_is_par,0,line,0) - call dcl_uproc(parser,'_head_node()=_shrd_node()==0',line) - - ! Parallel system nested contexts - call dcl_proc(parser,'_push_node_grid(arg...:any)',& - op_push_node_grid,0,line,proc_is_impure+proc_has_for) - call dcl_uproc(parser,'_push_node(d:int,t:int){'//& - '_push_node_grid(false,t)}',line) - call dcl_uproc(parser,'_push_node(d:tuple1d,t:tuple1d,e:tuple1d) { '//& - '_push_node_grid(is_cyclic(e.1),t.1) }',line) - call dcl_uproc(parser,'_push_node(d:tuple2d,t:tuple2d,e:tuple2d) { '//& - '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),t.1,t.2) }',& - line) - call dcl_uproc(parser,'_push_node(d:tuple3d,t:tuple3d,e:tuple3d) { '//& - '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& - 't.1,t.2,t.3) }',line) - call dcl_uproc(parser,'_push_node(d:tuple4d,t:tuple4d,e:tuple4d) { '//& - '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& - 'is_cyclic(e.4),'//& - 't.1,t.2,t.3,t.4) }',line) - call dcl_uproc(parser,'_push_node(d:tuple5d,t:tuple5d,e:tuple5d) { '//& - '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& - 'is_cyclic(e.4),is_cyclic(e.5),'//& - 't.1,t.2,t.3,t.4,t.5) }',line) - call dcl_uproc(parser,'_push_node(d:tuple6d,t:tuple6d,e:tuple6d) { '//& - '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& - 'is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),'//& - 't.1,t.2,t.3,t.4,t.5,t.6) }',line) - call dcl_uproc(parser,'_push_node(d:tuple7d,t:tuple7d,e:tuple7) { '//& - '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& - 'is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),'//& - 't.1,t.2,t.3,t.4,t.5,t.6,t.7) }',line) - - call dcl_proc(parser,'_push_node_split(int)',op_push_node_split,& - 0,& - line,proc_is_impure+proc_has_for) - call dcl_proc(parser,'_push_node_conc()',op_push_node_conc,0,& - line,0) - call dcl_uproc(parser,'PM__pop_node(x:mshape) {}',line) - call dcl_proc(parser,'PM__pop_node(x:shape)',op_pop_node,0,line,0) - call dcl_proc(parser,'PM__pop_conc(bool)',op_pop_node_conc,& - 0,line,0) - call dcl_proc(parser,'_push_node_dist()',op_push_node_distr,0,line,proc_is_impure+proc_has_for) - call dcl_uproc(parser,'_lvl()=1',line) - - - ! ************************************************ - ! PROCESSOR ALLOCATION - ! ************************************************ - - call dcl_uproc(parser,& - 'PM__partition(pp:null,dd:dshape)='//& - ' dd._tile,#dd._mshape,null',line) - call dcl_uproc(parser,& - 'PM__partition(pp,d:dshape) {'//& - '_push_node_dist();return dd._tile,dd,null where dd=new dshape {_mshape=#d._mshape,dist=d.dist,'//& - '_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level'//& - '}}',line) - call dcl_uproc(parser,& - 'PM__partition(pp,d:dshape,distr:null,topo:null,simplify:null,work:null,sched,block) {'//& - '_push_node_dist();return dd._tile,dd,_block_schedule(block,dd)'//& - ' where dd=new dshape {_mshape=#d._mshape,dist=d.dist,'//& - ' _tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level'//& - '}}',line) - call dcl_uproc(parser,& - 'PM__partition(pp,d:dshape,distr,topo,simplify,work,sched,block) {'//& - 'test "Cannot have attributes in ""for""statement over distributed value" => ''false;'//& - 'return dd._tile,dd,null where dd=new dshape {_mshape=##d,dist=d.dist,'//& - '_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level'//& - '}}',& - line) - call dcl_uproc(parser,'PM__partition(pp,d:mshape)=tile,shape,sched'//& - ' where tile,shape,sched='//& - ' PM__partition(pp,d,VBLOCK,null,null,null,null,null)',line) - call dcl_uproc(parser,& - 'PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) {'//& - ' d=dims(mshape);topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode()));'//& - ' var p=_shrd_node();'//& - ' dist=distribute(distr,d,topol);'//& - ' s=size(#(dist));np=shrd_nnode(); '//& - ' test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np;'//& - ' if s=s { '//& - ' p:=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) '//& - ' };'//& - ' _push_node_split(p) '//& - ' } else { '//& - ' _push_node_dist() '//& - ' }; '//& - ' elem=_get_elem(dist,p); elemsz=#elem; '//& - ' dd=new dshape {_mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz,'//& - ' _size=size(elemsz),_level=_lvl()};'//& - 'return dd._tile,dd,_block_schedule(block,dd) }',line) - call dcl_uproc(parser,& - 'PM__partition(pp:null,d:mshape,distr,topo,simplify,work,sched,block)='//& - '#d._extent,#d,_block_schedule(block,#d)',line) - call dcl_uproc(parser,& - 'PM__partition(pp:null,d:dshape,distr,topo,simplify,work,sched,block)='//& - '#d._extent,#d._mshape,_block_schedule(block,#d._mshape)',line) - - call dcl_uproc(parser,'_block_schedule(block:null,region)=null',line) - call dcl_uproc(parser,'_block_schedule(block,region)='//& - 'new schedule{_subregion=region,_subtile=region._tile,_blocking=_blocking(block,region)}',line) - - call dcl_uproc(parser,& - 'topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l)',line) - call dcl_uproc(parser,& - 'topology(tp,dis,d,l:int)=tp',line) - - call dcl_type(parser,& - 'distr_template is null,distr_template_dim,tuple(distr_template_dim),...',line) - call dcl_type(parser,& - 'distr_template_dim is null,vblock_template,'//& - 'block_template,cyclic_template,block_cyclic_template,...',line) - call dcl_type(parser,'vblock_template is unique{VBLOCK}',line) - call dcl_type(parser,'_block_template is rec{block:int}',line) - call dcl_type(parser,'_block_template_default is unique{BLOCK}',line) - call dcl_type(parser,& - 'block_template is _block_template_default,_block_template',line) - call dcl_uproc(parser,& - 'BLOCK(block:int)=new _block_template {block=block}',line) - call dcl_type(parser,'cyclic_template is unique{CYCLIC}',line) - call dcl_type(parser,'block_cyclic_template is rec {block:int}',line) - call dcl_uproc(parser,'BLOCK_CYCLIC(block:int)=new block_cyclic_template{block=block}',line) - - call dcl_uproc(parser,& - 'distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))='//& - 'map($distribute,dis,d,t):print("Topo:"++t)',line) - call dcl_uproc(parser,& - 'distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))='//& - 'map($distribute,spread(dis,d),d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t)',line) - - call dcl_uproc(parser,& - 'distribute(dis:null,d:int,t:int)='//& - 'no_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:vblock_template,d:int,t:int)='//& - 'vblock_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:_block_template,d:int,t:int)='//& - 'block_distr(d,t,dis.block)',line) - call dcl_uproc(parser,& - 'distribute(dis:block_template,d:int,t:int)='//& - 'block_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:cyclic_template,d:int,t:int)='//& - 'cyclic_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:block_cyclic_template,d:int,t:int)='//& - 'block_cyclic_distr(d,t,dis.block)',line) - - call dcl_uproc(parser,& - 'workshare(work:null,d,dist,nnode:int,'//& - 'snode:int,nsnode:int)='//& - 'nnode*(2*snode+1)/(2*nsnode)',line) - call dcl_uproc(parser,& - 'workshare(work:array(int),d,dist,nnode:int,snode:int,nsnode:int) { '//& - 'test "work array does not conform to mshape"=>'//& - 'conform(#work,#d); '//& - 'var wk=work;return _wshare(wk,nnode,snode,nsnode) }',line) - call dcl_proc(parser,& - '_wshare(int^any,int,int,int)->int',op_wshare,0,line,0) - - ! ************************************************************* - ! I/O OPERATIONS - ! ************************************************************* - - ! Built-in operators - call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->sint,sint',& - op_open_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_close_file(sint)->sint',& - op_close_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_seek_file(sint,lint)->sint',& - op_seek_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_read_file(sint,&any)->sint',& - op_read_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_write_file(sint,any)->sint',& - op_write_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_read_file_array(sint,&any,int)->sint',& - op_read_file_array,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_write_file_array(sint,any,int)->sint',& - op_write_file_array,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->sint',& - op_read_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) - call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->sint',& - op_write_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) - call dcl_proc(parser,'_io_error_string(sint)->string',& - op_io_error_string,0,line,proc_is_impure) - - ! IO/related types - call dcl_type(parser,'io_type is num,bool',line) - call dcl_type(parser,'filesystem is rec{_tag:PM__distr_tag}',line) - call dcl_type(parser,'file is struct {_f:sint,_tag:PM__distr_tag}',line) - call dcl_type(parser,'io_error is rec {_errno:sint,use _iserr:bool}',line) - call dcl_uproc(parser,'PM__filesys()=new filesystem{}',line) - - ! Basic operations - call dcl_uproc(parser,'open(&filesystem:filesystem,name,'//& - 'append=false,create=false,temp=false,'//& - 'excl=false,read=false,write=false,seq=false)=new file {_f=f},_make_file_error(err) '//& - 'where f,err=_open_file(name,append,create,'//& - 'temp,excl,read,write,seq)',line) - call dcl_uproc(parser,'_make_file_error(x:sint)=new io_error {_errno=x,_iserr=x/=0}',line) - call dcl_uproc(parser,'close(&f:file)'//& - '{err=_close_file(f._f);return _make_file_error(err)}',line) - call dcl_uproc(parser,'seek(&f:file,j:lint)'//& - '{err=_seek_file(f._f,j);return _make_file_error(err)}',line) - call dcl_uproc(parser,'read(&f:file,&x:io_type)'//& - '{err=_read_file(f._f,&x);return _make_file_error(err)}',line) - call dcl_uproc(parser,'write(&f:file,x:io_type)'//& - '{err=_write_file(f._f,x);return _make_file_error(err)}',line) - - ! Array I/O - call dcl_uproc(parser,& - 'read(&f:file,&x:io_type^mshape)'//& - '{err=_read_file_array(f._f,&x,size(x));return _make_file_error(err)}',line) - call dcl_uproc(parser,& - 'write(&f:file,x:io_type^mshape)'//& - '{err=_write_file_array(f._f,x,size(x));return _make_file_error(err)}',line) - call dcl_uproc(parser,& - 'read(&f:file,&x:io_type^dshape) '//& - '{var err=_make_file_error(0''s);for i in x:err:=read%(&f,&i);return err}',& - line) - call dcl_uproc(parser,& - 'write(&f:file,x:io_type^dshape) '//& - '{var err=_make_file_error(0''s);for i in x:err:=write%(&f,i)}',line) - - ! Distributed I/O - call dcl_uproc(parser,'partition%(f:filesystem)=f:test "Partition not yet implemented"=>''false',line) - call dcl_uproc(parser,& - 'read%(&f:shared file,&x:complete io_type)'//& - '{err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape));'//& - 'return _make_file_error(err)}',line) - call dcl_uproc(parser,& - 'write%(&f:shared file,x:complete io_type)'//& - '{err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape));'//& - 'return _make_file_error(err)}',line) - - ! Error trapping versions of I/O routines - call dcl_uproc(parser,'string(error:io_error)=_io_error_string(error._errno)',line) - call dcl_uproc(parser,'open(&f:filesystem,name:string,key...) {file,error=open(&f,name,key...);'//& - ' test "Error opening file """++name++""": "++error=>not(error);return file}',line) - call dcl_uproc(parser,'close(&f:file) '//& - '{error=close(&f);test "Error closing file:"++error=>not(error)}',line) - call dcl_uproc(parser,'read(&f:file,&x) '//& - '{error=read(&f,&x);test "Error reading from file:"++error=>not(error)}',line) - call dcl_uproc(parser,'write(&f:file,x) '//& - '{error=write(&f,x);test "Error writing to file:"++error=>not(error)}',line) - call dcl_uproc(parser,'seek(&f:file,x:lint) '//& - '{error=seek(&f,x);test "Error on seek:"++error=>not(error)}',line) - call dcl_uproc(parser,'read%(&f:shared file,&x) '//& - '{error=read%(&f,&x);test "Error reading from file:"++error=>not(error)}',line) - call dcl_uproc(parser,'write%(&f:shared file,x) '//& - '{error=write%(&f,x);test "Error writing to file:"=>not(error)}',line) - - ! ************************************************************* - ! SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS - ! ************************************************************* - - ! SOA tuples - call dcl_type(parser,'_stuple1d is rec^{t1}',line) - call dcl_type(parser,'_stuple2d is rec^{t1,t2}',line) - call dcl_type(parser,'_stuple3d is rec^{t1,t2,t3}',line) - call dcl_type(parser,'_stuple4d is rec^{t1,t2,t3,t4}',line) - call dcl_type(parser,'_stuple5d is rec^{t1,t2,t3,t4,t5}',line) - call dcl_type(parser,'_stuple6d is rec^{t1,t2,t3,t4,t5,t6}',line) - call dcl_type(parser,'_stuple7d is rec^{t1,t2,t3,t4,t5,t6,t7}',line) - - call dcl_uproc(parser,& - '_st(t1)=new _stuple1d{t1=t1}',line) - call dcl_uproc(parser,& - '_st(t1,t2)=new _stuple2d{t1=t1,t2=t2}',line) - call dcl_uproc(parser,& - '_st(t1,t2,t3)=new _stuple3d{t1=t1,t2=t2,t3=t3}',line) - call dcl_uproc(parser,& - '_st(t1,t2,t3,t4)=new _stuple4d{t1=t1,t2=t2,t3=t3,t4=t4}',line) - call dcl_uproc(parser,& - '_st(t1,t2,t3,t4,t5)=new _stuple5d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5}',line) - call dcl_uproc(parser,& - '_st(t1,t2,t3,t4,t5,t6)=new _stuple6d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6}',line) - call dcl_uproc(parser,& - '_st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7}',line) - - ! Create normalised form of a grid used for _xxx_slice operations - call dcl_uproc(parser,'_norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x))',line) - call dcl_uproc(parser,'_norm(n,x:map_seq)=_st(x.array)',line) - call dcl_uproc(parser,'_norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x))',line) - - ! Apply idxdim index and convert to normal for for _send_slice_mapped - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:single_point)='//& - '_st(m,t,t,1,1,0) where t=_dmap(x,n._t)',line) - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:range)='//& - '_st(m,_dmap(x,n._lo),_dmap(x,n._hi),1,1,0)',line) - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:strided_range)='//& - '_st(m,_dmap(x,n._lo),_dmap(x,n._hi),x._st*n._m,1,0)',line) - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1,''1),m,n:block_seq)='//& - '_st(m,n._lo+x._c,n._hi+x._c,n._st,n._b,n._align)',line) - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:block_seq)='//& - '_dnorm(x,m,map_seq(n))',line) - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:map_seq){'//& - 'var a=array(0,#n._array);for i in a,j in n._array <>:i:=_dmap(x,j);return _st(a)}',line) - call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:grid)='//& - '_st(map_apply($_dnorm,$_st,x,m,n),size(n))',line) - -!!$ call dcl_type(parser,'_griddef is rec^{grid,elems,size}',line) -!!$ call dcl_uproc(parser,'_gd(grid,elems,size)=new _griddef{grid=grid,elems=elems,size=size}',line) - - call dcl_type(parser,'_griddef is rec^{grid,elems}',line) - call dcl_uproc(parser,'_gd(grid,elems,size)=new _griddef{grid=grid,elems=elems}',line) - - call dcl_uproc(parser,& - '_send_slice(p,x:_comp^any,d) { '//& - 'for i in d <>{ _isend_offset%(j,p,x) '//& - 'where j=index(#x,i) } }',line) - call dcl_uproc(parser,& - '_send_slice(p,x,d) { '//& - '_isend_offset(_norm(dims(x),d),p,x) }',line) - call dcl_uproc(parser,& - '_send_slice_mapped(p,x,d,t,s) { '//& - 'for k in d <>{ _isend_offset%(j,p,x) '//& - 'where j=index(dims(s),s#i) where i=_dmap(t,k)}}',line) - call dcl_uproc(parser,& - '_send_slice_mapped(p,x:_comp^any,d,t:indexed_dim(''1),s) { '//& - 'for k in d <>{ _isend_offset%(j,p,x) '//& - 'where j=index(dims(s),s#i) where i=_dmap(t,k)}}',line) - call dcl_uproc(parser,& - '_send_slice_mapped(p,x,d,t:indexed_dim(''1),s) { '//& - '_isend_offset(_dnorm(t,dims(x),d),p,x)}',line) - - call dcl_uproc(parser,& - '_recv_slice(p,&x:_comp^any,d) { '//& - 'for i in d <>{ _irecv_offset%(j,p,&x) '//& - 'where j=index(#x,i) } }',line) - call dcl_uproc(parser,& - '_recv_slice(p,&x,d) { '//& - '_irecv_offset(_norm(dims(x),d),p,&x) }',line) - call dcl_uproc(parser,& - '_recv_slice_sync(p,&x:_comp^any,d) { '//& - 'for i in d <>{ _recv_offset%(j,p,&x) '//& - 'where j=index(#x,i) } }',line) - call dcl_uproc(parser,& - '_recv_slice_sync(p,&x,d) { '//& - '_recv_offset(_norm(dims(x),d),p,&x) }',line) - call dcl_uproc(parser,& - '_recv_slice_resend(p,&x:_comp^any,d) { '//& - 'for i in d <>{ _recv_resend%(j,p,&x) '//& - 'where j=index(#x,i) } }',line) - call dcl_uproc(parser,& - '_recv_slice_resend(p,&x,d) { '//& - '_recv_resend(_norm(dims(x),d),p,&x) }',line) - call dcl_uproc(parser,& - '_send_recv_slice_req(p,&x:_comp,a,sx,d,c:''true) {'//& - 'for i in d <>{ j=index(sx,i);'//& - '_isend_recv_req%(j,p,^(x),&^(^(a))); '//& - '} }',line) - call dcl_uproc(parser,& - '_send_recv_slice_req(p,x,&a,sx,d,c:''true) {'//& - '_isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a)))}',line) - call dcl_uproc(parser,& - '_send_recv_slice_req(p,x,&a,sx,d,c) {'//& - 'for i in d <>{ j=index(sx,i);_isend_recv_req%(j,p,^(x),&^(^(a)),c) '//& - '} }',line) - call dcl_uproc(parser,& - '_send_slice_assn(p,x:_comp,y,sx,d,c:''true) {'//& - 'for i in d <>{ _isend_assn%(j,^(p),^(x),^(y)) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_send_slice_assn(p,x,y,sx,d,c:''true) {'//& - '_isend_assn(_norm(dims(sx),d),p,x,y)}',line) - call dcl_uproc(parser,& - '_send_slice_assn(p,x,y,sx,d,c) {'//& - 'for i in d <>{ _isend_assn%(j,p,^(x),^(y),^(c)) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_recv_slice_reply(p,&x:_comp,sx,d,c:''true) {'//& - 'for i in d <>{ _recv_reply%(j,^(p),&^(^(x))) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_recv_slice_reply(p,&x,sx,d,c:''true) {'//& - '_recv_reply(_norm(dims(sx),d),p,&x) }',line) - call dcl_uproc(parser,& - '_recv_slice_reply(p,&x,sx,d,c) {'//& - 'for i in d <>{ _recv_reply%(j,p,&^(^(x)),c) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_bcast_slice(&x:_comp,sx,d,c:''true) {'//& - 'for i in d <>{ _bcast_slice_shared%(_gd(_norm(dims(sx),d),j,size(d)),_head_node(),&^(^(x))) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_bcast_slice(&x,sx,d,c:''true) {'//& - '_bcast_slice_shared(_gd(_norm(dims(sx),d),null,size(d)),_head_node(),&^(^(x)))}',line) - call dcl_uproc(parser,& - '_bcast_slice_shared(&x,sx,d,c) {'//& - 'for i in d <>{ _bcast_slice_shared%(j,_head_node(),&^(^(x)),c) '//& - 'where j=index(sx,i) } }',line) - - call dcl_proc(parser,'_isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any)',& - op_isend_offset,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_offset(j:any,p:any,x:any)',& - op_isend_grid,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_irecv_offset,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_irecv_offset(j:any,p:any,&x:any)',& - op_irecv_grid,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_recv_offset,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_offset(j:any,p:any,&x:any)',& - op_recv_grid,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_resend%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_recv_offset_resend,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_resend(j:any,p:any,&x:any)',& - op_recv_grid_resend,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend(p:any,x:any)',& - op_isend,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_irecv(p:any,&x:any)',& - op_irecv,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv(p:any,&x:any)',& - op_recv,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any)',& - op_isend_req,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_recv_req(j:any,p:any,x:any,&a:any)',& - op_isend_req,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any)',& - op_isend_req,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any)',& - op_isend_assn,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_assn(j:any,p:any,x:any,y:any)',& - op_isend_assn,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any)',& - op_isend_assn,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& - op_recv_reply,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_recv_reply,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_reply(j:any,p:any,&x:any)',& - op_recv_reply,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& - op_broadcast_disp,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_broadcast_disp,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_slice_shared(j:any,p:any,&x:any)',& - op_broadcast_disp,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_shared(&x:any)',op_broadcast_shared,0,line,proc_is_impure) - call dcl_type(parser,'_ct is array_slice,^*(,,,,),any^any,^^(any)',line) - - call dcl_uproc(parser,'PM__sync_messages(x)<>:_sync_messages(x)',line) - if(pm_is_compiling) then - call dcl_uproc(parser,'_sync_messages(x:_ct):_do_sync_messages(_core(x))',line) - call dcl_uproc(parser,'_sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y))',line) - call dcl_uproc(parser,'_core(x:any^any)=x',line) - call dcl_uproc(parser,'_core(x:^^(any))=x',line) - call dcl_uproc(parser,'_core(x:array_slice)=_core(x._a)',line) - call dcl_uproc(parser,'_core(x:^*(,,,,))=_core(_v2(x))',line) - call dcl_proc(parser,& - '_do_sync_messages(arg...:^^(any) or any^any)',& - op_sync_mess,0,line,proc_is_impure+proc_is_dcomm) - else - call dcl_proc(parser,& - '_sync_messages(arg...:_ct)',& - op_sync_mess,0,line,proc_is_impure+proc_is_dcomm) - endif - call dcl_uproc(parser,'_tup(x:tuple)=x',line) - call dcl_uproc(parser,'_tup(arg...)=tuple(arg...)',line) - call dcl_uproc(parser,'_tup(x:null)=x',line) - - call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',op_broadcast,& - 0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'PM__broadcast(b:any,a:int)->=b',op_broadcast_val,& - 0,line,proc_is_impure+proc_is_dcomm) - - call dcl_proc(parser,& - 'get_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& - 'b:int,c:int)->%a',& - op_get_remote_distr,& - 0,line,proc_is_impure+proc_is_dcomm) - - call dcl_proc(parser,& - 'put_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& - 'b:any,c:int,d:int)',& - op_put_remote_distr,& - 0,line,proc_is_impure+proc_is_dcomm) - - ! ******************************************************** - ! OTHER COMMUNICATING & ARRAY OPERATIONS - ! ******************************************************** - - call dcl_uproc(parser,'map(p:proc,x:any^any) {var z=array(_arb(x),#x);for i in z, j in x:i:=p.(j)}',line) - call dcl_uproc(parser,'map(p:proc,x:any^any,y:any^any) '//& - '{var z=array(p.(_arb(x),_arb(y)),#x);for i in z,j in x,k in y:i=p.(j,k)}',line) - call dcl_uproc(parser,'map(p:proc,x:any^mshape,y:any^dshape) '//& - '{var z=array(p.(_arb(x),_arb(y)),#(y));for i in z,j in x,k in y:i:=p.(j,k)}',line) - call dcl_uproc(parser,'map_const(p:proc,x:any^mshape,y:any)'//& - '{var z=array(p.(_arb(x),y),#x);for i in z,j in x:i:=p.(j,y)}',line) - - call dcl_uproc(parser,'+(x:num^any,y:num^any)=map($+,x,y)',line) - call dcl_uproc(parser,'-(x:num^any,y:num^any)=map($-,x,y)',line) - call dcl_uproc(parser,'*(x:num^any,y:num^any)=map($*,x,y)',line) - call dcl_uproc(parser,'/(x:num^any,y:num^any)=map($/,x,y)',line) - call dcl_uproc(parser,'**(x:num^any,y:num^any)=map($**,x,y)',line) - call dcl_uproc(parser,'mod(x:real_num^any,y:real_num^any)=map($mod,x,y)',line) - call dcl_uproc(parser,'max(x:real_num^any,y:real_num^any)=map($max,x,y)',line) - call dcl_uproc(parser,'min(x:real_num^any,y:real_num^any)=map($min,x,y)',line) - call dcl_uproc(parser,'+(x:num^any,y:any)=map_const($+,x,y)',line) - call dcl_uproc(parser,'-(x:num^any,y:any)=map_const($-,x,y)',line) - call dcl_uproc(parser,'*(x:num^any,y:any)=map_const($*,x,y)',line) - call dcl_uproc(parser,'/(x:num^any,y:any)=map_const($/,x,y)',line) - call dcl_uproc(parser,'**(x:num^any,y:any)=map_const($**,x,y)',line) - call dcl_uproc(parser,'mod(x:real_num^any,y:real_num)=map_const($mod,x,y)',line) - call dcl_uproc(parser,'max(x:real_num^any,y:real_num)=map_const($max,x,y)',line) - call dcl_uproc(parser,'min(x:real_num^any,y:real_num)=map_const($min,x,y)',line) - - call dcl_proc(parser,'_pack(v:any,any,any,d:any)->PM__dim v,d',& - op_pack,0,line,0) - call dcl_uproc(parser,'pack(v:any^mshape,m:bool^mshape) { '//& - ' test "arrays do not conform"=>conform(#v,#m); '//& - ' result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) }',line) - call dcl_uproc(parser,'pack(vv:array,mm:array) {'//& - ' var v=vv;var m=mm; '//& - ' return _pack(v,m,n,tuple(0..n-1))'//& - ' where n=count(m) }',line) - - - - ! Reduction - call dcl_type(parser,'associative_proc is $+,$*,$max,$min,'//& - '$&,$|,$xor,$++,$==,...',line) - - if(pm_is_compiling) then - call dcl_uproc(parser,'reduce(p:proc,x:array(,mshape)) {'//& - 'var s=_get_aelem(x,0);'//& - 'foreach i in 1..size(#x)-1 {'//& - 's:=p.(s,_get_aelem(x,i))'//& - '};return s}',line) - else - call dcl_uproc(parser,'reduce(p:proc,x:array(,mshape)) {'//& - 'var y=x;var n=size(x);'//& - 'while n>1 {'//& - ' var m=(n+1)/2;'//& - ' for k in m..n-1 <>{'//& - ' PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>)};'//& - ' n:=m};return _get_aelem(y,0)}',line) - endif - - call dcl_uproc(parser,'reduce(p:proc,y:array)='//& - '_reduce(p,reduce(p,PM__local(y)))',line) - - call dcl_uproc(parser,'_reduce_for_assign%(p:invar associative_proc,y,init:invar){'//& - 'chan yy=y;return reduce%(p,yy,init)}',line) - call dcl_uproc(parser,'_reduce_for_assign%(p:invar $-,y,init:invar){'//& - 'chan yy=y;return init - _reduce%($+,yy,init)}',line) - call dcl_uproc(parser,'_reduce_for_assign%(p:invar $/,y,init:invar){'//& - 'chan yy=y;return init / _reduce%($*,yy,init)}',line) - - call dcl_uproc(parser,'reduce%(p:invar proc,y:chan,init)='//& - '^(p.(init,_reduce(p,reduce(p,PM__local(y@) <>)<>)),uniform)',line) - call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& - '^(_reduce(p,reduce(p,PM__local(y@) <>)<>),uniform)',line) - - call dcl_uproc(parser,'_reduce(p:proc,y) {'//& - 'var x=array(y,[0..0]);var z=array(y,[0..0]);'//& - 'var n=this_nnode();var i=1;'//& - 'do {'//& - ' other=_this_node() xor i;'//& - ' if othern-1;return x[0]}',line) - - - ! ************************************************** - ! SUPPORT FOR OTHER LANGUAGE FEATURES - ! ************************************************** - - ! Keyword arguments - call dcl_uproc(parser,'PM__getkey(x:any,y:any)=convert(x,y)',line) - call dcl_uproc(parser,'PM__getkey(x:null,y:any)=y',line) - - ! Select statement - call dcl_uproc(parser,& - 'PM__checkcase(x,y,arg...) { var e=match_switch_case(x,y); '//& - 'if not e { e:=PM__checkcase(x,arg...) };return e }',line) - call dcl_uproc(parser,'PM__checkcase(x,y)=match_switch_case(x,y)',line) - call dcl_uproc(parser,'match_switch_case(x,y)=x==y',line) - call dcl_uproc(parser,& - 'match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi',& - line) - call dcl_uproc(parser,'match_switch_case(x:,y:)=y inc x',line) - - ! Conditional operators - call dcl_uproc(parser,& - 'PM__if(x,y,z) check "Incompatible types in different ""if""branches"=> '//& - 'same_type(y,z) { var r=z; if x { r:=y };return r }',& - line) - call dcl_uproc(parser,'PM__if(x:''true,y,z)=y',line) - call dcl_uproc(parser,'PM__if(x:''false,y,z)=z',line) - call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) - call dcl_uproc(parser,& - 'PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> '//& - 'same_type(y,z) { var r=z; if match(w,x) { r:=y };return r }',& - line) - call dcl_uproc(parser,'PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...))',line) - - ! Assignment - call dcl_uproc(parser,'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) - call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any) {check_assign_types(a,b);_assign(&a,b)}',line) - call dcl_type(parser,'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) - call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any,c:assignment_operator) { PM__assign(&a,c.(a,b)) }',line) - call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any,c:proc) { test "Not a recognised assignment operator"=>''false }',line) - call dcl_uproc(parser,'check_assign_types(x,y)'//& - '{test "Type mismatch in assignment"=>same_type(x,y)}',line) - call dcl_uproc(parser,'_assign(&a,b) {_assign_element(&a,b)}',line) - call dcl_uproc(parser,'_assign(&a:contains(farray),b) {_assign_structure(&a,b)}',line) - call dcl_uproc(parser,'_assign_structure(&a,b)<>{_assign_element(&a,b)}',line) - call dcl_uproc(parser,'_assign_structure(&a:farray,b){_array_assign(&a,b,''true)}',line) - call dcl_proc(parser,'_assign_element(&any,any)',op_assign,0,line,0) - - ! Other variable operations - call dcl_proc(parser,'PM__clone(x:any)->=x',op_clone,0,line,0) - call dcl_uproc(parser,'PM__dup(PM__dup) <>=PM__clone(PM__dup)',line) - call dcl_proc(parser,'PM__getref(x:any)->=x',op_get_rf,0,line,0) - call dcl_proc(parser,'same_type(x:any,y:any)->==x,y',& - op_logical_return,0,line,proc_needs_type) - call dcl_uproc(parser,'==(x:any,y:any) {'//& - 'test "Cannot apply ""=="" to different types"=> same_type(x,y);'//& - 'var ok=true;_eq(x,y,&ok);return ok}',line) - call dcl_uproc(parser,& - '_eq(x:any,y:any,&ok) <> { ok:=ok and x==y }',line) - call dcl_proc(parser,'PM__copy_out(x:any)->=x',op_clone,0,line,0) - call dcl_proc(parser,'PM__copy_back(x:any)->=x',op_assign,0,line,0) - - call dcl_uproc(parser,'next_enum(x:int)=x+convert(1,x)',line) - call dcl_uproc(parser,'next_enum(x:int,y:int)=x+convert(y,x)',line) - - ! Type values - call dcl_proc(parser,'typeof(x:any)->type x',op_make_type_val,0,line,proc_needs_type) - call dcl_uproc(parser,'is(x,t)=t inc typeof(x)',line) - call dcl_uproc(parser,'as(x,t:)...=PM__cast(x,t)',line) - call dcl_uproc(parser,'as(x,t)=PM__cast(x,typeof(t))',line) - call dcl_proc(parser,'inc(x:,y:)-> inc x,y',op_logical_return,0,line,proc_needs_type) - call dcl_uproc(parser,'==(x:,y:)=x inc y and y inc x',line) - call dcl_proc(parser,'error_type()->?int',0,0,line,proc_needs_type) - - ! Debugging - call dcl_proc(parser,'_dump(any,any)',op_new_dump,0,line,proc_is_impure) - call dcl_uproc(parser,'PM__dump(x)<>:_dump("Value:",x)',line) - call dcl_uproc(parser,'PM__dump(y,x)<>:if y:_dump("Value:",x)',line) - call dcl_uproc(parser,'PM__dump%(x)<>{print("$"++here);_dump(string(here),x)}',line) - call dcl_uproc(parser,'PM__dump%(y:bool,x)<>{if y:_dump(string(here),x)}',line) - call dcl_uproc(parser,'PM__dump%(y,x){'//& - 'test "Selection expression in ''$$dump'' not ''bool''" => ''false;$$infer_type(y)}',line) - - call dcl_proc(parser,'old_dump(any)',op_dump,0,line,proc_is_impure) - call dcl_uproc(parser,'old_dumpit(a) { old_dump(a);return a }',line) - call dcl_proc(parser,'old_dump_id(any)',op_dump_id,0,line,proc_is_impure) - - end subroutine sysdefs - -end module pm_sysdefs diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 359ec3f..dc8d70c 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -38,8 +38,8 @@ module pm_wcode use pm_symbol use pm_types use pm_sysdefs - use pm_parser - use pm_codegen + use pm_ast + use pm_cnodes use pm_infer implicit none @@ -1508,7 +1508,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) enddo endif case(sym_coherent,sym_partial,sym_set_mode,& - sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign) + sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_assignment) continue ! Nothing to do case(sym_cast) i=rvv(cnode_get_num(callnode,call_index)) From e2a9ef906785883766e204bb7b5bee20471ad3c7 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 29 Apr 2024 15:22:35 +0100 Subject: [PATCH 04/36] Remove call run_modes from sysdefs --- src/codegen.f90 | 6 +-- src/infer.f90 | 16 ++----- src/sysdefs.f90 | 113 ++++++++++++++++++++++++++---------------------- 3 files changed, 68 insertions(+), 67 deletions(-) diff --git a/src/codegen.f90 b/src/codegen.f90 index cd7ef9c..08ceb2a 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -816,10 +816,10 @@ subroutine update_change_lists(coder,var) integer:: if_scope if_scope=coder%if_scope do while(cnode_get_num(var,var_if_scope)0) then t=pm_type_vect(coder%context,coder%stack(base)) diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index 0273ca0..955a055 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -2857,6 +2857,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__redim(a,d)=_redim(a,d)',line) call dcl_uproc(parser,'PM__local(a:any^dshape)=_redim(a,(#a)._tilesz)',line) call dcl_uproc(parser,'PM__local(a:any^mshape)=a',line) + call dcl_uproc(parser,'PM__local%(x:shared)<>=PM__local(x)',line) call dcl_uproc(parser,'element(a:any^dshape,t) { '//& 'p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& 'var r=_arb(a);if p==_this_node():r=_get_aelem(a,i);_bcast_shared(&r,p);return r} ',line) @@ -3262,7 +3263,7 @@ subroutine sysdefs(parser) !!$ '_arb(x)'//& !!$ ':test "Cannot subscript distributed array in ""forall""" => ''false',line) call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y)',line) - call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,tuple(y <>))',line) + call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y))',line) ! Reference of non-distributed array with priv or indexed subscript @@ -3304,7 +3305,7 @@ subroutine sysdefs(parser) '{tt=_tup(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt)'//& 'return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null)}',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){'//& - 'tt=_tup(t <>);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& + 'tt=_tup%(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& 'return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null)}',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) {'//& 'tt=_tup(t);check_contains(#(_v1%(x)),tt);'//& @@ -3332,12 +3333,12 @@ subroutine sysdefs(parser) ! Subscript of distributed reference call dcl_uproc(parser,'_arb%(x:partial)=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:complete)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:chan)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:invar)=_arb(x <>)',line) + call dcl_uproc(parser,'_arb%(x:complete)<>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:chan)<>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:invar)<>=_arb(x)',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)='//& 'PM__dref(_arb%(_v1%(x)),x,_tup(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)='//& @@ -3349,7 +3350,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)='//& 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)='//& 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref)',line) @@ -3420,39 +3421,39 @@ subroutine sysdefs(parser) ' p=index(dims(region.dist),node);'//& ' _send_slice(p,a,region.dist[node])}}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) <> {'//& - 'chan var xx=_v1%(x);_getref_s(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_s(&xx,region,x,at) {'//& + 'chan var xx=_v1%(x);_getref_s%(&xx@,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) <> {'//& 'PM__head_node{_irecv(_v4(x),&xx)};'//& '_scatter(x,region);'//& '_sync_messages(xx,x)}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) <>{'//& - 'chan var xx=_v1%(x);_getref_sc(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_sc(&xx,region,x,at) {'//& + 'chan var xx=_v1%(x);_getref_sc%(&xx@,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) <> {'//& '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& '_sync_messages(xx,x)}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) <> {'//& - 'chan var a=_v1%(x);_getref_d(&^(PM__local(^(&a@) <>)),region,subregion(schedule),'//& - '^^(x),at <>);'//& + 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a@))),'//& + '^^(x),at <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_d(&a,region,subregion,x,at) {'//& + call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) <> {'//& '_get_dindex_from_dref(&a,x,t.2,'//& - '_local_region(region._tile,subregion),region,t.1,'//& + '_local_region(region._tile,subregion(schedule)),region,t.1,'//& '_drat(at,region._tile,t.1)) where t=_v4(x)'//& '}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) <> {'//& 'chan var a=_arb(_v2%(x));'//& - '_getref_dc(&a@,region,subregion(schedule),^^(x),at <>);_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dc(&a,region,subregion,x,at) {'//& + '_getref_dc%(&a@,^^(x),at <>);_bcast_shared(&a);return a}',line) + call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) <> {'//& 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& - '_local_region(region._tile,subregion),region,t.1,_drat(at,region._tile,t.1)) '//& + '_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) '//& ' where t=_v4(x)}}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) <> {'//& 'chan var a=_v1%(x);'//& - '_getref_dp(&^(^^(^(&a))),region,subregion(schedule),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& + '_getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dp(&a,region,subregion,x,at,atq,t) {'//& + call dcl_uproc(parser,'_getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) <>{'//& 'PM__head_node{_get_dindex_from_ref(&a,x,t.2,'//& - ' _local_region(region._tile,subregion),region,'//& + ' _local_region(region._tile,subregion(schedule)),region,'//& ' t.1,atq,_drat(at,region._tile,t.1))}'//& '}',line) @@ -3466,7 +3467,6 @@ subroutine sysdefs(parser) ' PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null);'//& ' v[u]=vvv};return v}',line) - ! Resolve reference locally (once communicated) call dcl_uproc(parser,'_getref_elem(x:any^mshape,i)=_get_aelem(x,i)',line) call dcl_uproc(parser,& @@ -3503,11 +3503,11 @@ subroutine sysdefs(parser) ! Assignment of distributed and/or shared or uniform references call dcl_uproc(parser,'PM__assign%(&x:priv,y,at) {'//& '_sync%(&x);PM__assign(&x,y <>)}',line) - call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_assign_to_invar%(&x,y) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_sync%(&x);_assign_to_invar%(&x,y) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) <> '//& + '{ PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) <>'//& + '{ PM__assign(&x,y) }',line) call dcl_uproc(parser,& '_assign_to_invar%(&x:invar,y:priv) '//& '{ test "Can only assign an ""invar"" value to an ""invar"" variable" => ''false }',line) @@ -3541,12 +3541,13 @@ subroutine sysdefs(parser) '{ PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y))}}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) {'//& - '_set_ref_dp(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& - ' region,subregion(schedule),$_just_assign,^^(^??),at,_v4(x) <>)}',line) + '_set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& + ' $_just_assign,^^(^??),at,_v4(x) <>)}',line) call dcl_uproc(parser,'_just_assign(x,y)=y',line) - call dcl_uproc(parser,'_set_ref_dp(&x,y,region,subregion,prc,atq,at,t) {'//& + call dcl_uproc(parser,'_set_ref_dp%(&x:invar,y:invar,'//& + ' prc:invar,atq:invar,at:invar,t:invar) <> {'//& '_set_dindex_of_ref(&x,y,t.2,'//& - '_local_region(region._tile,subregion),'//& + '_local_region(region._tile,subregion(schedule)),'//& 'region,t.1,prc,atq,at)'//& '}',line) @@ -3554,10 +3555,10 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv,y:priv,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv,y:invar,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:invar,y,pr,at) { _assign_to_invar%(&x,y,pr,at) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) <>'//& + '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) <> '//& + '{ PM__assign(&x,y,pr) }',line) call dcl_uproc(parser,'_assign_to_invar%(&x:invar,y:priv,pr,at){'//& '_assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) {'//& @@ -3577,9 +3578,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) {'//& 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr)}}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) {'//& - '_set_dindex_of_ref(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& + '_set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& '_local_region(region._tile,subregion(schedule)),'//& - 'region,t.1,pr,^^(^??),at <>)'//& + 'region,t.1,pr,^^(^??),at <>)'//& 'where t=_v4%(x)}',line) ! Resolve LHS reference (locally after communication) @@ -3950,6 +3951,10 @@ subroutine sysdefs(parser) '}',line) ! Resolve x[ indexed ][ whatever ] = priv + call dcl_uproc(parser,& + '_set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed,'//& + ' pr:invar proc,complt:invar,at:invar) <>:'//& + '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at)',line) call dcl_uproc(parser,& '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed,'//& ' pr:proc,complt,at) {'//& @@ -4047,7 +4052,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__nhd_join(x)=x._array',line) call dcl_uproc(parser,'PM__nhd_join(x,y)=new _join{head=x,tail=y._array}',line) call dcl_uproc(parser,'PM__nhd_var%(x,n:_nhd,i,h)<>='//& - 'new nbhd{_array=_make_nhd(^(x,shared),n._tilesz <>),_nbhd=n,_index=i,_here=h}',line) + 'new nbhd{_array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h}',line) call dcl_uproc(parser,'PM__nhd_active(region,nbhd,bound:null)=region._extent',line) call dcl_uproc(parser,& 'PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound)',line) @@ -4057,7 +4062,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b))',line) call dcl_uproc(parser,'_nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n)',line) - call dcl_uproc(parser,'_make_nhd(x,d){var v=array(x,d);return v}',line) + call dcl_uproc(parser,'_make_nhd%(x:invar,d:invar)<>{var v=array(x,d);return v}',line) call dcl_uproc(parser,'PM__set_edge%(&x,y,z){}',line) @@ -4918,7 +4923,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__get_elem%(x:shared,i,h)=PM__getelem(x,h)',line) call dcl_uproc(parser,'PM__set_elem%(&x:invar,v:complete,i,h)'//& - '{PM__setelem(&x,v,h <>);_assemble(&x,region <>)}',line) + '{PM__setelem(&x,v,h <>);_assemble%(&x,region)}',line) call dcl_uproc(parser,'PM__get_elem%(x:shared any^dshape,i,h)='//& 'element(PM__local(x),i)',line) @@ -4932,12 +4937,12 @@ subroutine sysdefs(parser) 'PM__setaelem(&x._a,i,v <>) check p==_this_node() '//& ' where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) }',line) !!! - call dcl_uproc(parser,'_assemble(&a:any^mshape,region:mshape) {}',line) + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region:mshape) {}',line) + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble(&a:any^mshape,region) {'//& - ' dist=region.dist; '//& + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar) <> {'//& + ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=dist[p];'//& ' i=index(dims(dist),p);'//& @@ -4956,8 +4961,8 @@ subroutine sysdefs(parser) ' } }',& line) - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region) {'//& - ' dist=region.dist; '//& + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar) <> {'//& + ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=intersect((#(a._a))#a._s,dist[p]);'//& ' i=index(dims(dist),p);'//& @@ -5009,7 +5014,8 @@ subroutine sysdefs(parser) endif ! active%() intrinsic - call dcl_uproc(parser,'active%(x)=masked(^(x,coherent),^(^??,coherent) <>)',line) + call dcl_uproc(parser,'active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>)',line) + call dcl_uproc(parser,'_masked%(x)<>=masked(x)',line) call dcl_uproc(parser,'active%()=^(^??,coherent)',line) call dcl_proc(parser,'PM__active()->bool',op_active,0,line,0) @@ -5076,10 +5082,10 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) call dcl_uproc(parser,'PM__do_over%(x:invar grid) <>'//& '{chan var t=false;'//& - ' _in(x,&^(PM__local(^(&t@))) <>);'//& + ' _in%(x,&^(PM__local(^(&t@))) <>);'//& ' return t}',line) call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) - call dcl_uproc(parser,'_in(x,&t){forall i in x {sync t[i]=true}}',line) + call dcl_uproc(parser,'_in%(x:invar,&t:invar)<>{forall i in x {sync t[i]=true}}',line) else call dcl_uproc(parser,'PM__do_over(x:null,region)=x',line) call dcl_uproc(parser,'PM__do_over(x:schedule,region)='//& @@ -5532,6 +5538,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_tup(x:tuple)=x',line) call dcl_uproc(parser,'_tup(arg...)=tuple(arg...)',line) call dcl_uproc(parser,'_tup(x:null)=x',line) + call dcl_uproc(parser,'_tup%(x:invar)<>=_tup(x)',line) call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',op_broadcast,& 0,line,proc_is_impure+proc_is_dcomm) @@ -5620,10 +5627,14 @@ subroutine sysdefs(parser) 'chan yy=y;return init / _reduce%($*,yy,init)}',line) call dcl_uproc(parser,'reduce%(p:invar proc,y:chan,init)='//& - '^(p.(init,_reduce(p,reduce(p,PM__local(y@) <>)<>)),uniform)',line) + '^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y@) <>)<>)),uniform)',line) call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& - '^(_reduce(p,reduce(p,PM__local(y@) <>)<>),uniform)',line) + '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y@) <>)<>),uniform)',line) + call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar)<>=reduce(p,y)',line) + call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar)<>=_reduce(p,y)',line) + + call dcl_uproc(parser,'_reduce(p:proc,y) {'//& 'var x=array(y,[0..0]);var z=array(y,[0..0]);'//& 'var n=this_nnode();var i=1;'//& From b2aeb8c0e1a675ba38e5a1322edcb83fc2d552f9 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 10 May 2024 15:22:32 +0100 Subject: [PATCH 05/36] New import/export system --- pm/Makefile | 2 +- src/codegen.f90 | 280 ++++++++++++++++++------------------------------ src/infer.f90 | 86 ++++++++------- src/main.f90 | 6 +- src/parser.f90 | 125 ++++++++++++--------- src/symbol.f90 | 14 +-- src/sysdefs.f90 | 90 ++++++++-------- src/types.f90 | 2 +- 8 files changed, 277 insertions(+), 328 deletions(-) diff --git a/pm/Makefile b/pm/Makefile index 0143700..2f05c4b 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -95,7 +95,7 @@ cnodes.o : ../src/cnodes.f90 ast.o symbol.o sysdefs.o types.o lib.o opts.o hash. codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -infer.o : ../src/infer.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< wcoder.o : ../src/wcoder.f90 array.o infer.o cnodes.o ast.o symbol.o sysdefs.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o diff --git a/src/codegen.f90 b/src/codegen.f90 index 08ceb2a..b78c802 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -136,7 +136,7 @@ module pm_codegen type(pm_ptr):: visibility ! Stack for local variables (stack() for names, var() for info records) - integer,dimension(max_code_stack):: stack + integer,dimension(max_code_stack):: stack,imps type(pm_ptr),dimension(max_code_stack):: var integer:: top @@ -156,8 +156,7 @@ module pm_codegen ! for & par statements - import/export type(pm_ptr):: loop_cblock - type(pm_ptr),dimension(max_par_depth):: & - imports,import_cblock,region + type(pm_ptr),dimension(max_par_depth):: import_cblock integer:: par_depth,proc_par_depth integer:: par_base,over_base @@ -210,7 +209,12 @@ module pm_codegen ! Type inference flag recursion -- use to locate infinite recursion logical:: flag_recursion - + + ! Type inference procedure trace + type(pm_ptr),dimension(max_par_depth):: trace + integer,dimension(max_par_depth)::trace_keys + integer:: trace_depth + ! Error count type(pm_ptr):: error_nodes(max_error_nodes) integer:: num_errors @@ -247,9 +251,7 @@ subroutine init_coder(context,coder,visibility) coder%proc_name_vals,coder%poly_cache,coder%comm_amp,array=& coder%vstack,array_size=coder%vtop) coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check,& - coder%check_mess,& - array=coder%imports,& - array_size=coder%par_depth) + coder%check_mess) coder%sig_cache=pm_dict_new(context,32_pm_ln) coder%prog_cblock=pm_null_obj coder%defer_check=pm_null_obj @@ -576,7 +578,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& case(par_state_cond,par_state_par) save_par_state=coder%par_state coder%par_state=par_state_labelled - call check_par_nesting(coder,cblock,node,.false.) + call check_par_context(coder,cblock,node,.false.) coder%label=node_arg(node,2) call make_const(coder,cblock,node,& node_arg(node,2)) @@ -676,7 +678,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call close_cblock(coder,cblock2) endif call set_var_as_shared(coder,pop_code(coder)) - call check_par_nesting(coder,cblock,node,.false.) + call check_par_context(coder,cblock,node,.false.) if(coder%vtop/=base) call pm_panic('pm_send/recv') case(sym_pm_bcast) call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& @@ -688,7 +690,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_expr(coder,cblock,node,node_arg(node,5)) call trav_stmt_list(coder,cblock,node,node_arg(node,6),sym_caret) call make_sp_call(coder,cblock,node,sym,4,2) - call check_par_nesting(coder,cblock,node,.false.) + call check_par_context(coder,cblock,node,.false.) case(sym_pm_recv_req) call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& var_is_shadowed) @@ -2336,6 +2338,7 @@ function code_par_scope_start(coder,cblock,stmt,var,using,& call make_sys_call(coder,cblock_main,stmt,sym_get_element,2,1) if(coder%top/=iter+7) then + write(*,*) '===========================' do i=iter,coder%top write(*,*) pm_name_as_string(coder%context,coder%stack(i)) enddo @@ -2424,11 +2427,10 @@ subroutine push_par_scope(coder,cblock) type(pm_ptr),intent(in):: cblock integer:: depth, kk depth=coder%par_depth - if(depth==max_par_depth) & - call pm_panic('Program too complex (nested loops)') + if(depth==max_par_depth) then + call pm_panic('Program too complex (nested parallel scopes)') + endif depth=depth+1 - coder%imports(depth)=& - pm_dict_new(coder%context,32_pm_ln) coder%import_cblock(depth)=cblock coder%par_depth=depth end subroutine push_par_scope @@ -2440,19 +2442,15 @@ subroutine pop_par_scope(coder,cblock,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer:: depth - depth=coder%par_depth - coder%imports(depth)=pm_null_obj coder%par_depth=coder%par_depth-1 contains include 'fisnull.inc' end subroutine pop_par_scope - !======================================================== + !==================================================================== ! Import argument list for a call - ! - returns parallel depth of call - ! Also returns export information for return values - ! at vstack locations base..vtop - !======================================================== + ! Arguments must be on vstack (nret, nkey, narg items respectively) + !==================================================================== subroutine import_args(coder,cblock,node,narg,nret,nkey,amps,flags,base) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,amps @@ -2496,7 +2494,7 @@ subroutine import_args(coder,cblock,node,narg,nret,nkey,amps,flags,base) if(export) then do i=top+1-narg-nkey-nret,top-narg-nkey - call var_set_par_depth(coder,coder%vstack(i),depth) + call var_set_par_depth(coder,coder%vstack(i),depth) enddo endif @@ -2513,7 +2511,6 @@ subroutine import_arg(index,modify) var=coder%vstack(index) if(pm_fast_vkind(var)/=pm_pointer) return if(cnode_get_kind(var)/=cnode_is_var) return - !write(*,*) 'IMPORT>',trim(pm_name_as_string(coder%context,cnode_get_name(var,var_name))) if(iscomm.and.index<=top+2-narg) return if(cnode_flags_set(var,var_flags,var_is_no_import_export)) then coder%vstack(index)=cnode_get(var,var_extra_info) @@ -2525,8 +2522,8 @@ subroutine import_arg(index,modify) 'Cannot modify variable from outside of parallel scope enclosing current parallel scope: ',& cnode_get(var,var_name)) nvar=var - elseif(modify.and.depth/=vdepth.and.& - (iand(flags,call_ignore_rules)==0.and.vdepthdepth.and.export) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call cnode_set_flags(top_code(coder),var_flags,var_is_imported) - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,node,sym_export_as_new,& - 1,1,coder%par_depth) - call var_set_par_depth(coder,top_code(coder),depth) - nvar=pop_code(coder) + if(cnode_flags_set(var,var_flags,var_is_imported)) then + nvar=cnode_get(var,var_extra_info) + else + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call cnode_set_flags(top_code(coder),var_flags,var_is_imported) + call code_val(coder,var) + call make_basic_sp_call(coder,cblock,node,sym_export_as_new,& + 1,1,coder%par_depth) + call var_set_par_depth(coder,top_code(coder),depth) + nvar=pop_code(coder) + endif else nvar=var endif @@ -2554,18 +2555,15 @@ end subroutine import_arg end subroutine import_args - !======================================================== ! Import a variable into a parallel scope at given depth !======================================================== - function import_to_par_scope(coder,cblock,node,var,depth,modify) result(ivar) + function import_to_par_scope(coder,cblock,node,var,depth) result(ivar) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,var integer,intent(in):: depth - logical,intent(in):: modify type(pm_ptr):: ivar - type(pm_ptr):: jvar,kvar,iblock - integer:: i,j,vdepth,vcdepth,name + integer:: i,j,vdepth,vcdepth,name,base ivar=var if(pm_fast_vkind(var)/=pm_pointer) return if(cnode_get_kind(var)/=cnode_is_var) return @@ -2573,130 +2571,47 @@ function import_to_par_scope(coder,cblock,node,var,depth,modify) result(ivar) ivar=cnode_get(var,var_extra_info) return endif - vdepth=cnode_get_num(var,var_par_depth)+coder%proc_par_depth + vdepth=par_depth(coder,var) vcdepth=cnode_get_num(var,var_create_depth)+coder%proc_par_depth - if(debug_codegen) then - write(*,*) 'IMPORT TO:',& - trim(pm_name_as_string(coder%context,& - cnode_get_num(var,var_name))),& - depth,vdepth,coder%par_depth,modify - endif - if(depth==0) then - ivar=var - elseif(vdepth>depth) then - ivar=var - elseif(vdepth==depth) then - ivar=var - elseif(modify.and.vdepth=coder%par_depth) then - iblock=cblock - else - iblock=coder%import_cblock(j) - endif - name=cnode_get_num(jvar,var_name) - if(name/=0) name=pm_name2(coder%context,sym_gt,name) - call make_sys_var(coder,iblock,node,& - name,var_is_shadowed+var_is_imported) - kvar=top_code(coder) - call cnode_set_num(kvar,var_par_depth,i-coder%proc_par_depth) - call code_val(coder,jvar) - - if(cnode_flags_set(jvar,var_flags,var_is_varg)) then - call cnode_set_flags(kvar,var_flags,var_is_varg) - call make_basic_sp_call(coder,iblock,node,& - sym_import_varg,1,1,i+1) - else - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call make_basic_sp_call(coder,iblock,node,& - sym_import_val,2,1,i+1) - endif - if(debug_codegen) then - write(*,*) 'IMPORT VAL> ',& - trim(pm_name_as_string(coder%context,& - cnode_get_num(var,var_name))),i - endif - ! Note cannot cache import to current level - ! - shared variable may change - ! - import may be in code that does not run - ! if 'false or similar - if(ivdepth) then + if(pm_debug_checks) then + if(depth/=vdepth+1) call pm_panic('import temp gone wrong') endif + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call code_val(coder,ivar) + call make_basic_sp_call(coder,cblock,node,sym_import_val,1,1,depth) + ivar=pop_code(coder) + elseif(vdepth' coder%flag_recursion=.false. - coder%par_depth=0 + coder%trace_depth=0 coder%poly_cache=pm_dict_new(coder%context,32_pm_ln) coder%first_pass=.true. @@ -390,7 +390,6 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& cnode%offset=sp_sig_break call pm_dict_set_val(coder%context,& coder%proc_cache,k,cnode) - coder%proc_par_depth=coder%par_depth coder%incomplete=.true. coder%taints=save_taints rtype=error_type @@ -897,21 +896,22 @@ subroutine prc_call(coder,cblock,callnode,base) call prc_cblock(coder,cnode_arg(args,2),base) case(sym_import_val,sym_import_param) tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) - coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,sym_shared,.false.) - if(tno>0.and.(coder%par_kind==par_mode_conc)) then - if(iand(pm_type_flags(coder%context,tno),& - pm_type_has_distributed)/=0) then - tno=pm_type_strip_mode(coder%context,arg_type_with_mode(3),mode) - if(iand(pm_type_flags(coder%context,tno),& - pm_type_has_distributed)==0) then - if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then - call infer_error_with_trace(coder,callnode,& - 'Cannot import distributed value into mirrored "forall"') - coder%stack(get_slot(1))=error_type - endif - endif + mode=merge(sym_shared,sym_mirrored,& + iand(pm_type_flags(coder%context,tno),& + pm_type_has_distributed)/=0) + coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,& + mode,.false.) + if(tno>0.and.coder%par_kind==par_mode_conc.and.mode==sym_shared) then + if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then + call infer_error_with_trace(coder,callnode,& + 'Cannot import distributed value into mirrored "forall"') + coder%stack(get_slot(1))=error_type endif endif + write(*,*) 'import to',trim(pm_name_as_string(coder%context,& + cnode_get_num(cnode_arg(args,1),var_name))),coder%stack(get_slot(1)),tno,& + cnode_get_num(cnode_arg(args,2),var_index),cnode_get_num(cnode_arg(args,1),var_index),& + coder%stack(86),get_slot(1) call flag_import_export(tno) case(sym_import_varg) tno=arg_type(2) @@ -924,21 +924,21 @@ subroutine prc_call(coder,cblock,callnode,base) tno=pm_type_strip_mode(coder%context,pm_tv_arg(t,i),mode) if(iand(pm_type_flags(coder%context,tno),pm_type_has_distributed)/=0) then call infer_error_with_trace(coder,callnode,& - 'Cannot use a distibuted shared value as an argument'//& + 'Cannot use a shared value as an argument'//& ' to a non-communicating operation') endif call push_word(coder,& - pm_type_add_mode(coder%context,tno,sym_shared,.false.)) + pm_type_add_mode(coder%context,tno,sym_mirrored,.false.)) enddo call make_type(coder,n+2) tno=pop_word(coder) coder%stack(get_slot(1))=tno call flag_import_export(tno) endif - case(sym_import_shared) - tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) - coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,sym_shared,.false.) - call flag_import_export(tno) +!!$ case(sym_import_shared) +!!$ tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) +!!$ coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,sym_shared,.false.) +!!$ call flag_import_export(tno) case(sym_export) tno=arg_type_with_mode(1) mode=pm_type_get_mode(coder%context,tno) @@ -1144,7 +1144,7 @@ subroutine prc_call(coder,cblock,callnode,base) if(mode>-1000) then namep=pm_name_val(coder%context,pm_tv_name(t2)) call infer_error_with_trace(coder,callnode,& - 'Cannot use a shared distributed value'//& + 'Cannot use a shared value'//& ' in "new" to initialise: '//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset-mode)))) @@ -1981,9 +1981,9 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ignore_rules.or.run_shared,is_complete,is_cond,is_unlabelled) if(mode<0) then if(mode>-1000) then - call call_error('Cannot pass a shared distributed value to a standard procedure') + call call_error('Cannot pass a shared value to a standard procedure') call infer_error_with_trace(coder,cnode_arg(args,nret-mode),& - 'Cannot pass a shared distributed value to a standard procedure') + 'Cannot pass a shared value to a standard procedure') elseif(mode>-2000) then call infer_error_with_trace(coder,cnode_arg(args,nret-mode-1000),& 'Cannot pass a "partial" value to a "complete" procedure'//& @@ -2543,17 +2543,16 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) ! Misuse loop stack as a traceback record ! of calls being processed - coder%par_depth=coder%par_depth+1 - if(coder%par_depth',coder%vtop,start,coder%incomplete @@ -3256,11 +3255,11 @@ subroutine infer_error(coder,node,message,name) if(modl_name==sym_pm_system.and.pm_opts%hide_sysmod) then ! Search call stack for source outside of the system module ! (note- par/import stack is misused here) - do i=coder%par_depth,1,-1 - modl_name=cnode_get_name(coder%imports(i),cnode_modl_name) + do i=coder%trace_depth,1,-1 + modl_name=cnode_get_name(coder%trace(i),cnode_modl_name) if(modl_name/=sym_pm_system) then - lineno=cnode_get_name(coder%imports(i),cnode_lineno) - charno=cnode_get_name(coder%imports(i),cnode_charno) + lineno=cnode_get_name(coder%trace(i),cnode_lineno) + charno=cnode_get_name(coder%trace(i),cnode_charno) exit endif enddo @@ -3289,9 +3288,8 @@ end subroutine infer_error ! ============================================================ ! Output trace of current call stack - ! Calls stored in coder%imports(1:coder%par_depth) - ! and coder%import_cblock(1:coder%par_depth) - ! misused for this purpose + ! Calls stored in coder%trace(1:coder%trace_depth) + ! and coder%trace_keys(1:coder%trace_depth) ! Ignores internal calls within PM__system ! unless pm_opts%hide_sysmod is false ! ============================================================= @@ -3301,14 +3299,14 @@ subroutine infer_trace(coder) integer:: k,top if(.not.pm_main_process) return if(coder%supress_errors) return - if(coder%par_depth<1) return - top=coder%par_depth + if(coder%trace_depth<1) return + top=coder%trace_depth if(pm_opts%hide_sysmod.and.top1) top=top-1 - node=coder%imports(top) + node=coder%trace(top) if(.not.hide(node)) then !!$ call pm_error_header(coder%context,& !!$ cnode_get_name(node,cnode_modl_name),& @@ -3323,7 +3321,7 @@ subroutine infer_trace(coder) endif if(top==1.and.pm_opts%hide_sysmod) then - if(hide(coder%imports(top))) return + if(hide(coder%trace(top))) return endif write(*,*) @@ -3333,11 +3331,11 @@ subroutine infer_trace(coder) write(*,*) 'Procedure call: (call not recorded)' cycle endif - node=coder%imports(k) + node=coder%trace(k) if((.not.hide(node)).or.& (.not.pm_opts%hide_sysmod)) then call print_call_details(coder,node,& - int(coder%import_cblock(k)%offset)) + coder%trace_keys(k)) if(k>1) write(*,*) endif enddo diff --git a/src/main.f90 b/src/main.f90 index 04f472a..dd26155 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -112,7 +112,7 @@ subroutine run_parser(mname,root,dict,visibility) type(pm_ptr),intent(out):: root,dict,visibility ! Parser state type(parse_state),target:: parser - integer:: name + integer:: name,module_name,package_name character(len=pm_max_filename_size):: str,str2 if(pm_debug_level>1) write(*,*) 'PARSING>>' @@ -151,8 +151,8 @@ subroutine run_parser(mname,root,dict,visibility) parser%modl%offset+modl_link) if(pm_fast_isnull(parser%modl)) exit str=' ' - call pm_name_string(context,& - get_modl_name(parser%modl),str) + module_name=get_modl_name(parser%modl) + call pm_name_string(context,module_name,str) call pm_module_filename(str,str2) call pm_open_file(pm_comp_file_unit,str2,ok) if(.not.ok) then diff --git a/src/parser.f90 b/src/parser.f90 index a62b4ab..9e0b75e 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -4326,6 +4326,57 @@ end function arg_type_with_mode end function param_list + !====================================================== + ! Specialised kind of communicating procedure + !====================================================== + function proc_comm_kinds(parser,flags) result(iserr) + type(parse_state),intent(inout):: parser + integer,intent(inout):: flags + logical:: iserr + iserr=.true. + do + select case(parser%sym) + case(sym_shared) + call set_flags(proc_run_shared) + call scan(parser) + case(sym_pm_node) + call set_flags(proc_run_local+proc_run_always) + call scan(parser) + case(sym_complete) + call set_flags(proc_run_complete) + call scan(parser) + case(sym_cond_attr) + call set_flags(proc_is_cond) + call scan(parser) + case(sym_uncond) + call set_flags(proc_is_uncond) + call scan(parser) + end select + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + if(iand(flags,proc_is_cond+proc_is_uncond)==& + proc_is_cond+proc_is_uncond) then + call parse_error(parser,& + 'Cannot have both "cond" and "uncond" together') + endif + iserr=.false. + contains + subroutine set_flags(new_flags) + integer,intent(in):: new_flags + if(iand(flags,proc_is_comm)==0) then + call parse_error(parser,& + 'Can only apply "'//trim(sym_names(parser%sym))//& + '" to a communicating procedure') + endif + if(iand(flags,new_flags)/=0) then + call parse_error(parser,& + 'Cannot repeat "'//trim(sym_names(parser%sym))//'"') + endif + flags=ior(flags,new_flags) + end subroutine set_flags + end function proc_comm_kinds + !====================================================== ! Procedure/call attributes !====================================================== @@ -4334,16 +4385,15 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) logical,intent(in):: iscall integer,intent(inout):: flags logical:: iserr - logical:: iscomm integer:: m iserr=.true. call scan(parser) - iscomm=iand(flags,proc_is_comm)/=0 do select case(parser%sym) case(sym_each) + call set_flags(proc_is_each_proc) if(iscall) then - call bad_attr + call parse_error(parser,'each^ in call') exit endif call scan(parser) @@ -4358,48 +4408,22 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) enddo call make_node(parser,sym_each,m) if(expect(parser,sym_close)) return - flags=ior(flags,proc_is_each_proc) - case(sym_shared) - if(iscomm.eqv.iscall) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_shared) - case(sym_pm_node) - if(iscomm.eqv.iscall) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_local+proc_run_always) - case(sym_complete) - if(iscomm.eqv.iscall) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_complete) case(sym_always) - if((.not.iscomm).and.(.not.iscall)) then - call bad_attr + if(iscall) then + call parse_error(parser,& + '"always" is not a valid attribute for a call') endif + call set_flags(proc_run_always) call scan(parser) - flags=ior(flags,proc_run_always) case(sym_inline) + call set_flags(proc_inline) call scan(parser) - flags=ior(flags,proc_inline) case(sym_no_inline) + call set_flags(proc_no_inline) call scan(parser) - flags=ior(flags,proc_no_inline) - case(sym_cond_attr) - call scan(parser) - if(iscall.or..not.iscomm) call bad_attr - flags=ior(flags,proc_is_cond) - case(sym_uncond) + case(sym_ignore_rules) + call set_flags(call_ignore_rules) call scan(parser) - if(iscall.or..not.iscomm) call bad_attr - flags=ior(flags,proc_is_uncond) - case(sym_ignore_rules) - call scan(parser) - flags=ior(flags,call_ignore_rules) end select if(parser%sym/=sym_comma) exit call scan(parser) @@ -4409,25 +4433,19 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) call parse_error(parser,& 'Cannot have both "<>" and "<>" attributes together') endif - if(iand(flags,proc_is_cond+proc_is_uncond)==& - proc_is_cond+proc_is_uncond) then - call parse_error(parser,& - 'Cannot have both "<>" and "<>" attributes together') - endif if(expect(parser,sym_close_attr)) return iserr=.false. contains - subroutine bad_attr - if(iscall) then - call parse_error(parser,& - 'Cannot have "'//trim(sym_names(parser%sym))//& - '" attribute in a communicating call') - else - call parse_error(parser,& - 'Cannot have "'//trim(sym_names(parser%sym))//& - '" attribute in a non-communicating procedure') + subroutine set_flags(new_flags) + integer,intent(in):: new_flags + if(iand(flags,new_flags)/=0) then + if(.not.(iand(flags,proc_run_local)/=0.and.new_flags==proc_run_always)) then + call parse_error(parser,& + 'Cannot repeat attribute "'//trim(sym_names(parser%sym))//'"') + endif endif - end subroutine bad_attr + flags=ior(flags,new_flags) + end subroutine set_flags end function proc_call_attr !====================================================== @@ -4534,6 +4552,9 @@ function proc_decl(parser,method_name,param_base) result(iserr) nret=-1 endif + ! Special kinds of comm proc + if(proc_comm_kinds(parser,flags)) goto 999 + ! Attributes if(parser%sym==sym_open_attr) then if(proc_call_attr(parser,.false.,flags)) goto 999 diff --git a/src/symbol.f90 b/src/symbol.f90 index 6d0d86c..e3d9a4c 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -153,12 +153,13 @@ module pm_symbol integer,parameter:: last_key = sym_shared ! Declaration keywords - integer,parameter:: sym_use = last_key + 1 + integer,parameter:: sym_package = last_key +1 + integer,parameter:: sym_use = last_key + 2 integer,parameter:: first_decl = sym_use - integer,parameter:: sym_proc = last_key + 2 - integer,parameter:: sym_param = last_key + 3 - integer,parameter:: sym_type = last_key + 4 - integer,parameter:: sym_render = last_key + 5 + integer,parameter:: sym_proc = last_key + 3 + integer,parameter:: sym_param = last_key + 4 + integer,parameter:: sym_type = last_key + 5 + integer,parameter:: sym_render = last_key + 6 integer,parameter:: last_decl = sym_render ! Statement keywords @@ -559,6 +560,7 @@ module pm_symbol data sym_names(sym_shared) /'shared'/ ! Declaration keywords + data sym_names(sym_package) /'package'/ data sym_names(sym_use) /'use'/ data sym_names(sym_proc) /'proc'/ data sym_names(sym_param) /'param'/ diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index 955a055..ffc8743 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -2857,7 +2857,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__redim(a,d)=_redim(a,d)',line) call dcl_uproc(parser,'PM__local(a:any^dshape)=_redim(a,(#a)._tilesz)',line) call dcl_uproc(parser,'PM__local(a:any^mshape)=a',line) - call dcl_uproc(parser,'PM__local%(x:shared)<>=PM__local(x)',line) + call dcl_uproc(parser,'PM__local%(x:shared) shared =PM__local(x)',line) call dcl_uproc(parser,'element(a:any^dshape,t) { '//& 'p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& 'var r=_arb(a);if p==_this_node():r=_get_aelem(a,i);_bcast_shared(&r,p);return r} ',line) @@ -3280,7 +3280,7 @@ subroutine sysdefs(parser) 'PM__dref($[](x,t),x,t,null,null)',line) ! Subscript or slice of distributed array - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) <>'//& + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) complete <>'//& '{tt=_tup(t);check_contains(#(x),tt);'//& 'return PM__dref(_arb(x),x,i,p,_s_ref) '//& 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) @@ -3292,13 +3292,13 @@ subroutine sysdefs(parser) '{tt=_tup(t);check_contains(#(x),tt);var xx=varray(_arb(x),empty(#x));'//& 'return PM__drefs(xx,x,tt,p,_p_ref) '//& 'where p=nodes_for_grid((#x).dist,tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed)<>=PM__subref%(x,*t)',line) + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t)',line) call dcl_uproc(parser,& - 'PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) <> {'//& + 'PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond {'//& 'check_contains(#x,_dmap(t,here));'//& 'return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t)}',line) call dcl_uproc(parser,& - 'PM__subref%(x:shared any^dshape,t:invar indexed)<>=PM__subref%(x,*t)',line) + 'PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t)',line) ! Subscript or slice of non-distristuted array which is itself result of variant slice call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index)'//& @@ -3333,9 +3333,9 @@ subroutine sysdefs(parser) ! Subscript of distributed reference call dcl_uproc(parser,'_arb%(x:partial)=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:complete)<>=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:chan)<>=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:invar)<>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:complete) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:chan) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:invar) complete <>=_arb(x)',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)='//& 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) @@ -3420,38 +3420,38 @@ subroutine sysdefs(parser) ' d=#region._mshape;a={_getref(_import_dref%(x),j): j in d};'//& ' p=index(dims(region.dist),node);'//& ' _send_slice(p,a,region.dist[node])}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> {'//& 'chan var xx=_v1%(x);_getref_s%(&xx@,^^(x),at);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) <> {'//& + call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_irecv(_v4(x),&xx)};'//& '_scatter(x,region);'//& '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) <>{'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{'//& 'chan var xx=_v1%(x);_getref_sc%(&xx@,^^(x),at);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) <> {'//& + call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) PM__node {'//& '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> {'//& 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a@))),'//& '^^(x),at <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) <> {'//& + call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) PM__node {'//& '_get_dindex_from_dref(&a,x,t.2,'//& '_local_region(region._tile,subregion(schedule)),region,t.1,'//& '_drat(at,region._tile,t.1)) where t=_v4(x)'//& '}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> {'//& 'chan var a=_arb(_v2%(x));'//& '_getref_dc%(&a@,^^(x),at <>);_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) <> {'//& + call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& '_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) '//& ' where t=_v4(x)}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> {'//& 'chan var a=_v1%(x);'//& '_getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) <>{'//& + call dcl_uproc(parser,'_getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node {'//& 'PM__head_node{_get_dindex_from_ref(&a,x,t.2,'//& ' _local_region(region._tile,subregion(schedule)),region,'//& ' t.1,atq,_drat(at,region._tile,t.1))}'//& @@ -3504,9 +3504,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv,y,at) {'//& '_sync%(&x);PM__assign(&x,y <>)}',line) call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_sync%(&x);_assign_to_invar%(&x,y) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) <> '//& + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) complete '//& '{ PM__assign(&x,y <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) <>'//& + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) shared'//& '{ PM__assign(&x,y) }',line) call dcl_uproc(parser,& '_assign_to_invar%(&x:invar,y:priv) '//& @@ -3545,7 +3545,7 @@ subroutine sysdefs(parser) ' $_just_assign,^^(^??),at,_v4(x) <>)}',line) call dcl_uproc(parser,'_just_assign(x,y)=y',line) call dcl_uproc(parser,'_set_ref_dp%(&x:invar,y:invar,'//& - ' prc:invar,atq:invar,at:invar,t:invar) <> {'//& + ' prc:invar,atq:invar,at:invar,t:invar) PM__node {'//& '_set_dindex_of_ref(&x,y,t.2,'//& '_local_region(region._tile,subregion(schedule)),'//& 'region,t.1,prc,atq,at)'//& @@ -3555,9 +3555,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv,y:priv,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv,y:invar,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:invar,y,pr,at) { _assign_to_invar%(&x,y,pr,at) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) <>'//& + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete'//& '{ PM__assign(&x,y,pr <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) <> '//& + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared '//& '{ PM__assign(&x,y,pr) }',line) call dcl_uproc(parser,'_assign_to_invar%(&x:invar,y:priv,pr,at){'//& '_assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at)}',line) @@ -3953,7 +3953,7 @@ subroutine sysdefs(parser) ! Resolve x[ indexed ][ whatever ] = priv call dcl_uproc(parser,& '_set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed,'//& - ' pr:invar proc,complt:invar,at:invar) <>:'//& + ' pr:invar proc,complt:invar,at:invar) PM__node <>:'//& '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at)',line) call dcl_uproc(parser,& '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed,'//& @@ -4009,7 +4009,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'_nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits}',line) call dcl_type(parser,'nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here}',line) - call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,bound:invar)<>='//& + call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,bound:invar) shared <>='//& 'new _nhd {_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),'//& '_limits=_expand_limits(region._extent,envelope(x),bound)} '//& 'where t=_get_halo(region,region._tile,envelope(x))',line) @@ -4062,7 +4062,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b))',line) call dcl_uproc(parser,'_nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n)',line) - call dcl_uproc(parser,'_make_nhd%(x:invar,d:invar)<>{var v=array(x,d);return v}',line) + call dcl_uproc(parser,'_make_nhd%(x:invar,d:invar) shared <>{var v=array(x,d);return v}',line) call dcl_uproc(parser,'PM__set_edge%(&x,y,z){}',line) @@ -4096,7 +4096,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_positive(x)=x>0',line) call dcl_uproc(parser,& - 'PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) <> { '//& + 'PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { '//& ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& @@ -4123,7 +4123,7 @@ subroutine sysdefs(parser) '}}',line) call dcl_uproc(parser,& - 'PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) <> { '//& + 'PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& @@ -4150,12 +4150,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner)',line) call dcl_uproc(parser,'_foot(d,n:extent)=n',line) - call dcl_uproc(parser,'PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) <> {'//& + call dcl_uproc(parser,'PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& 'PM__head_node{_apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region),'//& ' envelope(nbhd._nbhd),b,rank(extent(region)),''true)}}',line) call dcl_uproc(parser,& - 'PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) <> { '//& + 'PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& @@ -4173,7 +4173,7 @@ subroutine sysdefs(parser) '}}',line) call dcl_uproc(parser,& - 'PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) <> {'//& + 'PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& 'if shrd_nnode()>1 {'//& ' foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 {'//& ' chunk=chunk(region,envelope(nbhd._nbhd),i,b);'//& @@ -4941,7 +4941,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar) <> {'//& + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar) shared <> {'//& ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=dist[p];'//& @@ -4961,7 +4961,7 @@ subroutine sysdefs(parser) ' } }',& line) - call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar) <> {'//& + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> {'//& ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=intersect((#(a._a))#a._s,dist[p]);'//& @@ -4988,7 +4988,7 @@ subroutine sysdefs(parser) ! Support for @ operator if(pm_is_compiling) then call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region,size(region))',line) + 'PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region))',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region,size(region))'//& ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) @@ -5000,7 +5000,7 @@ subroutine sysdefs(parser) op_make_array,0,line,proc_needs_type) else call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region)',line) + 'PM__makearray%(x:chan) complete <>=_makearray(x,region)',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region)'//& ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) @@ -5015,7 +5015,7 @@ subroutine sysdefs(parser) ! active%() intrinsic call dcl_uproc(parser,'active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>)',line) - call dcl_uproc(parser,'_masked%(x)<>=masked(x)',line) + call dcl_uproc(parser,'_masked%(x) complete <>=masked(x)',line) call dcl_uproc(parser,'active%()=^(^??,coherent)',line) call dcl_proc(parser,'PM__active()->bool',op_active,0,line,0) @@ -5048,18 +5048,18 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'subtile(schedule:schedule)=schedule._subtile',line) ! Over statements - call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar)<>='//& + call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar) shared <>='//& 'new schedule{_subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region)}',line) - call dcl_uproc(parser,'PM__over%(x:invar,block:invar)<>='//& + call dcl_uproc(parser,'PM__over%(x:invar,block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'where s=intersect(x,schedule._subregion)',line) call dcl_uproc(parser,'PM__make_over%(schedule:null,'//& - 'x:invar tuple(subs_dim except stretch_dim),block:invar)<>='//& + 'x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s '//& 'where s=fill_in(region._extent,x,null)',line) call dcl_uproc(parser,'PM__make_over%(x:invar tuple(subs_dim except stretch_dim)'//& - ',block:invar)<>='//& + ',block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'where s=intersect(map($norm,fill_in(region._extent,x,''true)),schedule._subregion)',line) call dcl_uproc(parser,'PM__make_over%(x:invar,block)=x'//& @@ -5080,12 +5080,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__do_over%(x:null)=true',line) call dcl_uproc(parser,'PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion',line) call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) - call dcl_uproc(parser,'PM__do_over%(x:invar grid) <>'//& + call dcl_uproc(parser,'PM__do_over%(x:invar grid) complete <>'//& '{chan var t=false;'//& ' _in%(x,&^(PM__local(^(&t@))) <>);'//& ' return t}',line) call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) - call dcl_uproc(parser,'_in%(x:invar,&t:invar)<>{forall i in x {sync t[i]=true}}',line) + call dcl_uproc(parser,'_in%(x:invar,&t:invar) shared <>{forall i in x {sync t[i]=true}}',line) else call dcl_uproc(parser,'PM__do_over(x:null,region)=x',line) call dcl_uproc(parser,'PM__do_over(x:schedule,region)='//& @@ -5538,7 +5538,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_tup(x:tuple)=x',line) call dcl_uproc(parser,'_tup(arg...)=tuple(arg...)',line) call dcl_uproc(parser,'_tup(x:null)=x',line) - call dcl_uproc(parser,'_tup%(x:invar)<>=_tup(x)',line) + call dcl_uproc(parser,'_tup%(x:invar) shared=_tup(x)',line) call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',op_broadcast,& 0,line,proc_is_impure+proc_is_dcomm) @@ -5631,8 +5631,8 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y@) <>)<>),uniform)',line) - call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar)<>=reduce(p,y)',line) - call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar)<>=_reduce(p,y)',line) + call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y)',line) + call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y)',line) call dcl_uproc(parser,'_reduce(p:proc,y) {'//& diff --git a/src/types.f90 b/src/types.f90 index 5e7b849..24628b5 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -571,7 +571,7 @@ function pm_type_flags(context,tno) result(flags) integer:: flags integer:: tno2 type(pm_ptr):: tv - if(tno==0) then + if(tno<=0) then flags=pm_type_has_generic return else From 7a0686fd4f4f4f804c5828252805db13686bcf41 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Wed, 5 Jun 2024 14:17:49 +0100 Subject: [PATCH 06/36] Added split initialisation --- src/array.f90 | 8 +- src/ast.f90 | 85 ++++--- src/cnodes.f90 | 40 ++-- src/codegen.f90 | 341 +++++++++++++++++++-------- src/deadcode.f90 | 68 ++++++ src/infer.f90 | 591 ++++++++++++++++++++++++++++++++--------------- src/linker.f90 | 2 +- src/memory.f90 | 119 +++++----- src/parser.f90 | 189 +++++++++------ src/symbol.f90 | 87 ++++--- src/sysdefs.f90 | 396 ++++++++++++++++++++----------- src/types.f90 | 157 +++++++++---- src/vmdefs.f90 | 29 +++ src/wcoder.f90 | 15 +- 14 files changed, 1456 insertions(+), 671 deletions(-) diff --git a/src/array.f90 b/src/array.f90 index c8e82fb..587b7bb 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -4471,11 +4471,15 @@ function make_string_vector(context,val,esize) result(str) type(pm_reg),pointer:: reg reg=>pm_register(context,'make_str',len,off,vec) len=pm_new(context,pm_long,esize+1) - len%data%ln(len%offset:len%offset+esize)=pm_fast_esize(val) + len%data%ln(len%offset:len%offset+esize)=pm_fast_esize(val)+1 off=pm_new(context,pm_long,esize+1) off%data%ln(off%offset:off%offset+esize)=0 vec=pm_new(context,pm_pointer,esize+1) - vec%data%ptr(vec%offset:vec%offset+esize)=val + if(pm_fast_esize(val)<0) then + vec%data%ptr(vec%offset:vec%offset+esize)=pm_fast_newnc(context,pm_string,1) + else + vec%data%ptr(vec%offset:vec%offset+esize)=val + endif str=make_array(context,pm_array_type,int(pm_string_type),vec,len,len,off) call pm_delete_register(context,reg) contains diff --git a/src/ast.f90 b/src/ast.f90 index 33ec223..5d5654f 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -24,6 +24,7 @@ ! THE SOFTWARE. ! Definitions for abstract syntax tree +! and some more general definition of flag values etc. module pm_ast use pm_sysdep @@ -57,15 +58,15 @@ module pm_ast integer,parameter:: node_args=5 ! Type parse nodes - integer,parameter:: typ_name=node_args - integer,parameter:: typ_number=node_args+1 - integer,parameter:: typ_module=node_args+2 - integer,parameter:: typ_params=node_args+3 - integer,parameter:: typ_constraints=node_args+4 - integer,parameter:: typ_link=node_args+5 - integer,parameter:: typ_ins=node_args+6 - integer,parameter:: typ_includes=node_args+7 - integer,parameter:: typ_num_args=8 + integer,parameter:: type_name=node_args + integer,parameter:: type_number=node_args+1 + integer,parameter:: type_module=node_args+2 + integer,parameter:: type_params=node_args+3 + integer,parameter:: type_constraints=node_args+4 + integer,parameter:: type_link=node_args+5 + integer,parameter:: type_parents=node_args+6 + integer,parameter:: type_includes=node_args+7 + integer,parameter:: type_num_args=8 ! Proc parse nodes integer,parameter:: proc_name=node_args @@ -83,7 +84,7 @@ module pm_ast ! Alternative final sections for 'proc' parse nodes - ! - user functions + ! - user procs integer,parameter:: proc_reduce=node_args+12 integer,parameter:: proc_check=node_args+13 integer,parameter:: proc_result=node_args+14 @@ -91,7 +92,7 @@ module pm_ast integer,parameter:: proc_code_tree=node_args+16 integer,parameter:: proc_num_args=17 - ! - built in functions + ! - built in procs integer,parameter:: proc_retas=node_args+12 integer,parameter:: proc_opcode=node_args+13 integer,parameter:: proc_opcode2=node_args+14 @@ -99,24 +100,56 @@ module pm_ast integer,parameter:: proc_coded_builtin=node_args+16 integer,parameter:: sysproc_num_args=17 - ! Values for flags (other values defined in sysdefs) - integer,parameter:: proc_is_comm=1 - integer,parameter:: proc_run_complete=2 - integer,parameter:: proc_run_local=4 - integer,parameter:: proc_run_shared=8 - integer,parameter:: proc_run_always=16 - integer,parameter:: proc_inline=32 - integer,parameter:: proc_no_inline=64 - integer,parameter:: proc_is_open=128 - integer,parameter:: proc_is_each_proc=256 - integer,parameter:: proc_is_cond=512 - integer,parameter:: proc_is_uncond=1024 - integer,parameter:: proc_is_abstract=2048 + ! Values for proc flags + integer,parameter:: proc_is_comm= 1 + integer,parameter:: proc_run_complete= 2 + integer,parameter:: proc_run_local= 4 + integer,parameter:: proc_run_shared= 8 + integer,parameter:: proc_run_always= 16 + integer,parameter:: proc_inline= 32 + integer,parameter:: proc_no_inline= 64 + integer,parameter:: proc_is_open= 128 + integer,parameter:: proc_is_each_proc= 256 + integer,parameter:: proc_is_cond= 512 + integer,parameter:: proc_is_uncond= 1024 + integer,parameter:: proc_is_abstract= 2048 + integer,parameter:: proc_is_thru_each = 2**12 + integer,parameter:: proc_is_empty_each = 2**13 + integer,parameter:: proc_is_dup_each = 2**14 + integer,parameter:: proc_is_var = 2**15 + integer,parameter:: proc_is_generator = 2**16 + integer,parameter:: proc_needs_type = 2**17 + integer,parameter:: proc_is_recursive = 2**18 + integer,parameter:: proc_unfinished = 2**19 + integer,parameter:: proc_is_impure = 2**20 + integer,parameter:: proc_is_not_inlinable = 2**21 + integer,parameter:: proc_has_for = 2**22 + integer,parameter:: proc_is_not_pure_each = 2**23 + integer,parameter:: proc_has_vkeys = 2**24 + integer,parameter:: proc_is_dcomm = 2**25 + integer,parameter:: proc_is_file = 2**26 + integer,parameter:: proc_needs_par = 2**27 + integer,parameter:: proc_prints_out = 2**28 - ! Corresponding flags in proc calls (must be same as for proc_is) + ! Proc flags that can be taken as taints + integer,parameter:: proc_taints = proc_is_impure & + + proc_is_not_inlinable + proc_has_for & + + proc_is_not_pure_each + proc_is_dcomm + proc_is_file & + + proc_needs_par + proc_prints_out + + ! Flags for proc calls integer,parameter:: call_is_comm=1 integer,parameter:: call_ignore_rules=256 - + integer,parameter:: call_is_fixed = 2**10 + integer,parameter:: call_is_assign_call = 2**11 + integer,parameter:: call_is_vararg = 2**12 + integer,parameter:: call_inline_when_compiling = 2**13 + integer,parameter:: call_dup_result = 2**14 + integer,parameter:: call_is_cond = 2**15 + integer,parameter:: call_is_no_touch = 2**16 + integer,parameter:: call_is_unlabelled = 2**17 + integer,parameter:: call_is_uninitialised = 2**18 + contains !====================================================== diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 0e3bf71..ab73724 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -92,24 +92,14 @@ module pm_cnodes integer,parameter:: call_sig=cnode_args+2 integer,parameter:: call_flags=cnode_args+3 integer,parameter:: call_link=cnode_args+4 - integer,parameter:: call_nret=cnode_args+5 - integer,parameter:: call_nkeys=cnode_args+6 - integer,parameter:: call_index=cnode_args+7 - integer,parameter:: call_par_depth=cnode_args+8 - integer,parameter:: call_var=cnode_args+9 - integer,parameter:: call_amp=cnode_args+10 - integer,parameter:: call_node_size=11 - - ! Flags for call nodes - ! (call_is_comm=1.. defined in parser) - integer,parameter:: call_is_fixed = 2**10 - integer,parameter:: call_is_assign_call = 2**11 - integer,parameter:: call_is_vararg = 2**12 - integer,parameter:: call_inline_when_compiling = 2**13 - integer,parameter:: call_dup_result = 2**14 - integer,parameter:: call_is_cond = 2**15 - integer,parameter:: call_is_no_touch = 2**16 - integer,parameter:: call_is_unlabelled = 2**17 + integer,parameter:: call_back_link=cnode_args+5 + integer,parameter:: call_nret=cnode_args+6 + integer,parameter:: call_nkeys=cnode_args+7 + integer,parameter:: call_index=cnode_args+8 + integer,parameter:: call_par_depth=cnode_args+9 + integer,parameter:: call_var=cnode_args+10 + integer,parameter:: call_amp=cnode_args+11 + integer,parameter:: call_node_size=12 ! Offsets into var cnodes integer,parameter:: var_parent=cnode_args+0 @@ -504,11 +494,15 @@ subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) type(pm_ptr),intent(in):: rvec,sig_cache,cnode integer:: flags if(cnode_get_kind(cnode)==cnode_is_builtin) then - write(iunit,'(a)') ' Builtin '//& - op_names(cnode_get_num(cnode,cnode_args))//& - pm_int_as_string(cnode_get_num(cnode,cnode_args+1))//'{' - if(.not.pm_fast_isnull(cnode_get(cnode,bi_rcode))) then - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,bi_rcode),4) + if(cnode_get_num(cnode,cnode_args)>=0) then + write(iunit,'(a)') ' Builtin '//& + op_names(cnode_get_num(cnode,cnode_args))//& + pm_int_as_string(cnode_get_num(cnode,cnode_args+1))//'{' + else + write(iunit,'(a)') ' Fold {' + if(.not.pm_fast_isnull(cnode_get(cnode,bi_rcode))) then + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,bi_rcode),4) + endif endif write(iunit,'(a)') ' }' else diff --git a/src/codegen.f90 b/src/codegen.f90 index b78c802..259c5ba 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -174,7 +174,7 @@ module pm_codegen type(pm_ptr):: temp,temp2,true,false,one,comm_amp,check_mess,undef_val ! 'true and 'false types - integer:: true_name,false_name + integer:: true_fix,false_fix,true_literal,false_literal ! '1 type integer:: unit_type @@ -275,7 +275,7 @@ subroutine init_coder(context,coder,visibility) coder%one=pm_new_small(context,pm_long,1_pm_p) coder%one%data%ln(coder%one%offset)=1 - coder%unit_type=pm_new_value_type(coder%context,coder%one) + coder%unit_type=pm_new_fix_type(coder%context,coder%one) coder%one=pm_new_small(context,pm_int,1_pm_p) coder%one%data%i(coder%one%offset)=1 @@ -289,8 +289,10 @@ subroutine init_coder(context,coder,visibility) coder%check_mess=pm_new_string(coder%context,'Failed "check" or "test""') coder%proc_name_vals=pm_dict_new(coder%context,8_pm_ln) coder%id=0 - coder%true_name=pm_new_value_type(coder%context,coder%true) - coder%false_name=pm_new_value_type(coder%context,coder%false) + coder%true_fix=pm_new_fix_type(coder%context,coder%true) + coder%false_fix=pm_new_fix_type(coder%context,coder%false) + coder%true_literal=pm_new_literal_type(coder%context,coder%true) + coder%false_literal=pm_new_literal_type(coder%context,coder%false) coder%default_label=pm_fast_name(coder%context,sym_pct) coder%label=coder%default_label @@ -336,7 +338,7 @@ subroutine trav_prog(coder,stmt_list) ! Some general constants call make_const(coder,prog_cblock,stmt_list,& - pm_fast_tinyint(coder%context,-9999)) + pm_fast_tinyint(coder%context,-9999),int(pm_tiny_int)) coder%undef_val=pop_code(coder) ! filesystem variable @@ -490,6 +492,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call drop_code(coder) case(sym_while,sym_while_invar) save_par_state=coder%par_state + j=push_if_scope(coder) call make_const(coder,cblock,node,node_arg(node,1)) cblock2=make_cblock(coder,cblock,node,sym_while) call trav_xexpr(coder,cblock2,node,node_arg(node,2)) @@ -500,16 +503,21 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& coder%par_state=save_par_state coder%par_state=par_state_for_loop(coder,node,coder%par_state,& node_get_num(node,node_args)/=0,sym==sym_while_invar) + coder%if_scope=j call trav_stmt_list(coder,cblock,node,& node_arg(node,3),sym_while) - call make_sp_call(coder,cblock,node,sym_while,4,0) + n=get_if_scope(coder) + call make_sp_call(coder,cblock,node,sym_while,4+n,0) + call pop_if_scope(coder) coder%par_state=save_par_state case(sym_until,sym_until_invar) + j=push_if_scope(coder) call make_const(coder,cblock,node,node_arg(node,1)) save_par_state=coder%par_state coder%par_state=par_state_for_loop(coder,node,coder%par_state,& node_get_num(node,node_args)/=0,sym==sym_until_invar) cblock2=make_cblock(coder,cblock,node,sym_until) + coder%if_scope=j call trav_open_stmt_list(coder,cblock2,node,& node_arg(node,3)) iscomm=cnode_flags_set(top_code(coder),cblock_flags,cblock_is_comm) @@ -518,8 +526,10 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call code_check_invar(coder,cblock2,node,top_code(coder)) endif call close_cblock(coder,cblock2) + n=get_if_scope(coder) call make_sp_call(coder,cblock,node,& - sym_until,3,0) + sym_until,3+n,0) + call pop_if_scope(coder) coder%par_state=save_par_state case(sym_do_stmt) call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) @@ -556,7 +566,19 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& p=node_arg(node,1) call trav_call(coder,cblock,node,p,0,.true.) case(sym_var,sym_const) - ! No init var/const + do j=1,node_numargs(node)-1 + call make_var(coder,cblock,node,node_arg(node,j),ior(var_is_not_inited,& + merge(var_is_var,0,sym==sym_var))) + enddo + call push_word(coder,pm_type_new_uninitialised) + call push_word(coder,0) + call push_word(coder,pm_type_new_type) + call push_word(coder,0) + call trav_type(coder,node,node_arg(node,node_numargs(node))) + call make_type(coder,3) + call make_type(coder,3) + call code_num(coder,pop_word(coder)) + call make_sp_call(coder,cblock,node,sym_var,node_numargs(node)-1,1) case(sym_with) base=coder%top call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) @@ -825,7 +847,6 @@ subroutine update_change_lists(coder,var) end do end subroutine update_change_lists - !============================================== ! Add var to change list headed by list !============================================== @@ -862,7 +883,6 @@ subroutine retrieve_change_list(coder,list,count) count=0 p=list do while(.not.pm_fast_isnull(p)) - !call qdump_code_tree(coder,pm_null_obj,6,p%data%ptr(p%offset),2) call code_val(coder,p%data%ptr(p%offset)) p=p%data%ptr(p%offset+1) count=count+1 @@ -919,6 +939,19 @@ subroutine apply_x(nodep,node) select case(node_sym(node)) case(sym_define) call trav_assign_define(coder,cblock,nodep,node) + case(sym_case) + do i=1,node_numargs(node) + nodei=node_arg(node,i) + if(node_sym(nodei)==sym_dotdot) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call trav_expr(coder,cblock,node,node_arg(nodei,1)) + call trav_expr(coder,cblock,node,node_arg(nodei,2)) + call make_sys_call(coder,cblock,node,sym_case_range,2,1) + else + call trav_expr(coder,cblock,node,nodei) + endif + enddo case(sym_assign_list) call trav_assign_define_list(coder,cblock,nodep,node) case(sym_sync_assign) @@ -1013,18 +1046,34 @@ recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) type(pm_ptr),intent(in):: stmt,var integer,intent(in):: idx,sym type(pm_ptr):: cblock2 - integer:: base,save_par_state,n,j + integer:: base,save_par_state,n,i,j j=push_if_scope(coder) - call make_temp_var(coder,cblock,stmt) - call dup_code(coder) base=coder%vtop - call code_val(coder,var) + call trav_xexpr(coder,cblock,stmt,node_arg(stmt,idx)) + n=coder%vtop-base + do i=1,n + if(i1) call swap_code_2_1(coder) + endif + call make_temp_var(coder,cblock,stmt) + call dup_code(coder) + call code_val(coder,var) + call code_val(coder,coder%vstack(base+i)) + call make_sys_call(coder,cblock,stmt,& + sym_checkcase,2,1) + if(i>1) then + call make_sys_call(coder,cblock,stmt,& + sym_or,2,1) + endif + enddo + coder%vstack(base+1)=top_code(coder) + coder%vtop=base+1 if(sym==sym_if_invar) then call code_check_invar(coder,cblock,stmt,top_code(coder)) endif - call make_sys_call(coder,cblock,stmt,& - sym_checkcase,coder%vtop-base,1) coder%if_scope=j call trav_stmt_list(coder,cblock,stmt,& node_arg(stmt,idx+1),sym_switch) @@ -1170,7 +1219,7 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba type(pm_ptr):: save_loop_cblock logical:: iscomm,outer,invar,c_invar sym=node_sym(stmt) - rbase=coder%vtop + wbase=coder%wtop invar=sym==sym_foreach_invar c_invar=pm_is_compiling.and.invar @@ -1178,6 +1227,9 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba if(debug_codegen) write(*,*) 'TRAVEACH>' + j=push_if_scope(coder) + rbase=coder%vtop + ! Process iterator expression call trav_iter(coder,cblock,list,sym_dims,lbase,vbase,nlist) @@ -1231,6 +1283,8 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba call make_var_assignment(coder,cblock,stmt,coder%var(iter+lv_end),aflags=rflags) endif endif + + coder%if_scope=j ! Loop body cblock2=make_cblock(coder,cblock,list,sym_each) @@ -1310,7 +1364,8 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba ! Build call call code_val(coder,coder%var(iter+lv_end)) - call make_sp_call(coder,cblock,list,sym_each,3,0) + n=get_if_scope(coder) + call make_sp_call(coder,cblock,list,sym_each,3+n,0) ! Clean up coder%par_state=save_par_state @@ -1318,6 +1373,8 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba call pop_vars_to(coder,vbase) + call pop_if_scope(coder) + contains include 'fisnull.inc' include 'fisname.inc' @@ -2265,7 +2322,7 @@ function code_par_scope_start(coder,cblock,stmt,var,using,& call trav_expr(coder,cblock_pre,using,node_arg(using,i)) enddo do i=n+1,num_using_clauses - call make_const(coder,cblock,using,pm_null_obj) + call make_const(coder,cblock,using,pm_null_obj,int(pm_null)) enddo call make_sys_call(coder,cblock_pre,using,& sym_partition,& @@ -2397,7 +2454,7 @@ subroutine code_par_scope_end(coder,iter,node,& call code_val(coder,pm_null_obj) !!!@ Legacy - need to remove call code_val(coder,coder%var(iter+lv_num)) if(is_conc) then - call make_const(coder,cblock,node,pm_null_obj) + call make_const(coder,cblock,node,pm_null_obj,int(pm_null)) else call make_const(coder,cblock,node,coder%true) endif @@ -2784,7 +2841,12 @@ subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) if(pm_fast_isnull(var)) then call make_definition(coder,cblock,node,lhs,0) else - call make_assignment(coder,cblock,node,lhs,rhs,var) + if(iand(cnode_get_num(var,var_flags),& + var_is_var+var_is_not_inited)==var_is_not_inited) then + call make_split_definition(coder,cblock,node,var) + else + call make_assignment(coder,cblock,node,lhs,rhs,var) + endif endif contains include 'fisname.inc' @@ -2912,24 +2974,29 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) if(present(avar)) then call trav_ref_to_var(coder,cblock,pnode,node,0,avar) call assign_call(pnode,outer,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),.false.) + cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& + cnode_flags_set(top_code(coder),var_flags,var_is_not_inited),& + .false.) elseif(node_sym(node)==sym_underscore) then call drop_code(coder) return elseif(pm_fast_isname(node)) then call trav_ref_to_var(coder,cblock,pnode,node,0) call assign_call(pnode,outer,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),.false.) + cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& + cnode_flags_set(top_code(coder),var_flags,var_is_not_inited),& + .false.) else sym=node_sym(node) select case(sym) case(sym_sub,sym_dot_sub,sym_dot,sym_get_dot,sym_at) outmode=trav_ref(coder,cblock,pnode,node,0) - call assign_call(node,outer,.false.,iand(outmode,ref_has_at)/=0) + call assign_call(node,outer,.false.,.false.,iand(outmode,ref_has_at)/=0) case(sym_name) call trav_ref_to_var(coder,cblock,node,node_arg(node,1),0) call assign_call(node,outer,& cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& + cnode_flags_set(top_code(coder),var_flags,var_is_not_inited),& .false.) case default !write(*,*) sym_names(sym) @@ -2943,18 +3010,24 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) include 'fisnull.inc' include 'ftiny.inc' - subroutine assign_call(pnode,outer,simple,has_pling) + subroutine assign_call(pnode,outer,simple,undef,has_pling) type(pm_ptr),intent(in):: pnode - logical,intent(in):: outer,simple - logical,intent(in):: has_pling + logical,intent(in):: outer,simple,undef,has_pling type(pm_ptr):: v,w if(.not.coder%in_sync) then - call swap_code(coder) - call make_assign_call(coder,cblock,pnode,& - merge(sym_aliased_assign,& - merge(sym_assign_var,sym_assignment,simple),& - present(alias)),& - 2,0,aflags=call_is_assign_call) + if(simple.and.undef) then + call dup_code(coder) + call swap_code_2_1(coder) + call make_sys_call(coder,cblock,pnode,& + sym_assign_or_init,2,1,aflags=call_is_uninitialised) + else + call swap_code(coder) + call make_assign_call(coder,cblock,pnode,& + merge(sym_aliased_assign,& + merge(sym_assign_var,sym_assignment,simple),& + present(alias)),& + 2,0,aflags=call_is_assign_call) + endif else v=pop_code(coder) w=pop_code(coder) @@ -3037,7 +3110,8 @@ recursive subroutine make_definition(coder,cblock,node,vname,flags) var=top_code(coder) call swap_code(coder) call make_sys_call(coder,cblock,pnode,& - sym_dup,1,1,aflags=coder%run_flags) + merge(sym_dup,sym_clone,iand(flags,var_is_var)/=0),& + 1,1,aflags=coder%run_flags) call make_var_mode(coder,cblock,node,var) elseif(node_sym(name)==sym_underscore) then call drop_code(coder) @@ -3051,6 +3125,21 @@ recursive subroutine make_definition(coder,cblock,node,vname,flags) include 'fisnull.inc' end subroutine make_definition + !=================================================================== + ! Use expression on top of stack to initialise a constant + !=================================================================== + recursive subroutine make_split_definition(coder,cblock,node,var) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,node,var + call code_val(coder,var) + call make_sp_call(coder,cblock,node,sym_const,1,0) + call code_val(coder,var) + call swap_code(coder) + call make_sys_call(coder,cblock,node,sym_clone,& + 1,1) + call update_change_lists(coder,var) + end subroutine make_split_definition + !======================================================== ! Reference to a variable !======================================================== @@ -3104,10 +3193,6 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,mode,avar) call update_change_lists(coder,var) endif endif - if(iand(flags,var_is_not_inited)/=0) then - call code_error(coder,pnode,& - 'Cannot assign to a non-initialised variable: ',name) - endif if(iand(mode,ref_is_val)/=0) then var=import_to_par_scope(coder,cblock,pnode,var,coder%par_depth) endif @@ -3617,7 +3702,7 @@ recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) if(which(i)>0) then call make_static_long_const(coder,cblock,node,int(which(i),pm_ln)) else - call make_const(coder,cblock,node,pm_null_obj) + call make_const(coder,cblock,node,pm_null_obj,int(pm_null)) endif end do call make_sys_call(coder,cblock,node,sym_tuple,max_idx-1,1) @@ -3646,7 +3731,8 @@ subroutine define_sys_var(coder,cblock,node,name,flags) call make_sys_var(coder,cblock,node,name,flags) var=top_code(coder) call swap_code(coder) - call make_sys_call(coder,cblock,node,sym_dup,1,1,aflags=call_ignore_rules) + call make_sys_call(coder,cblock,node,& + merge(sym_dup,sym_clone,iand(flags,var_is_var)/=0),1,1,aflags=call_ignore_rules) call make_var_mode(coder,cblock,node,var) end subroutine define_sys_var @@ -3658,7 +3744,9 @@ subroutine init_var(coder,cblock,node,var) type(pm_ptr),intent(in):: cblock,node,var call code_val(coder,var) call swap_code(coder) - call make_sys_call(coder,cblock,node,sym_dup,1,1,aflags=call_ignore_rules) + call make_sys_call(coder,cblock,node,& + merge(sym_dup,sym_clone,cnode_flags_set(var,var_flags,var_is_var)),& + 1,1,aflags=call_ignore_rules) call make_var_mode(coder,cblock,node,var) end subroutine init_var @@ -3713,6 +3801,7 @@ subroutine make_var_assignment(coder,cblock,node,var,aflags) call make_assign_call(coder,cblock,node,sym_assignment,2,0,aflags=flags) endif call cnode_set_flags(v,var_flags,var_is_changed) + call update_change_lists(coder,var) end subroutine make_var_assignment @@ -3781,11 +3870,19 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) loop_flags=0 select case(sym) case(sym_true) - call make_const(coder,cblock,pnode,coder%true) + if(coder%fixed) then + call make_const(coder,cblock,pnode,coder%true,coder%true_fix) + else + call make_const(coder,cblock,pnode,coder%true) + endif case(sym_false) - call make_const(coder,cblock,pnode,coder%false) + if(coder%fixed) then + call make_const(coder,cblock,pnode,coder%false,coder%false_fix) + else + call make_const(coder,cblock,pnode,coder%false) + endif case(sym_null) - call make_const(coder,cblock,pnode,pm_null_obj) + call make_const(coder,cblock,pnode,pm_null_obj,int(pm_null)) case(sym_arg,sym_name,sym_use) call trav_name(coder,cblock,node,sym,node_arg(node,1)) case(sym_proc) @@ -3836,7 +3933,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) p%offset==sym_true) else call make_const(coder,cblock,node,p,& - pm_new_value_type(coder%context,p)) + pm_new_fix_type(coder%context,p)) endif return case(sym_fix) @@ -3844,7 +3941,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call dup_code(coder) save_fixed=coder%fixed coder%fixed=.true. - call trav_closed_expr(coder,cblock,node,node_arg(node,1)) + call trav_expr(coder,cblock,node,node_arg(node,1)) coder%fixed=save_fixed call make_sp_call(coder,cblock,node,sym_dash,1,1) case(sym_present) @@ -3864,8 +3961,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call make_temp_var(coder,cblock,node) endif endif - case(first_operator:last_operator,& - sym_if_expr,sym_switch_expr) + case(first_operator:last_operator) call make_temp_var(coder,cblock,node) call dup_code(coder) do i=1,node_numargs(node) @@ -3874,6 +3970,45 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) enddo call make_sys_call(coder,cblock,node,& sym,node_numargs(node),1) + case(sym_if_expr) + call make_temp_var(coder,cblock,node) + call dup_code(coder) + do i=1,node_numargs(node) + call trav_expr(coder,cblock,& + node,node_arg(node,i)) + enddo + call make_sys_call(coder,cblock,node,& + sym,node_numargs(node),1) + case(sym_switch_expr) + n=node_numargs(node) + do i=2,n-2 + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call make_temp_var(coder,cblock,node) + call dup_code(coder) + if(i==2) then + call trav_expr(coder,cblock,node,node_arg(node,1)) + base=coder%vtop + else + call dup_expr(coder,coder%vstack(base)) + endif + p=node_arg(node,i) + if(node_sym(p)==sym_dotdot) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call trav_expr(coder,cblock,node,node_arg(p,1)) + call trav_expr(coder,cblock,node,node_arg(p,2)) + call make_sys_call(coder,cblock,node,sym_case_range,2,1) + else + call trav_expr(coder,cblock,node,p) + endif + call make_sys_call(coder,cblock,node,sym_checkcase,2,1) + call trav_expr(coder,cblock,node,node_arg(node,i+1)) + enddo + call trav_expr(coder,cblock,node,node_arg(node,n)) + do i=2,n-2 + call make_sys_call(coder,cblock,node,sym_if_expr,3,1) + enddo case(sym_uhash,sym_ustar) if(coder%par_state>par_state_outer) then call make_temp_var(coder,cblock,node) @@ -4022,7 +4157,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) elseif(coder%par_state=pm_int) then + tno=pm_new_literal_type(coder%context,val) + else + tno=pm_fast_typeof(val) + endif if(coder%par_state/=par_state_outer) then tno=pm_type_add_mode(coder%context,tno,sym_mirrored,.false.) endif @@ -8099,7 +8242,7 @@ subroutine make_full_call(coder,cblock,node,procs,& iand(iflag,call_ignore_rules)==0) then if(coder%par_state==par_state_outer) then call code_error(coder,node,& - 'Cannot have "<>", "<>", "<>" or "<>" attributes'//& + 'Cannot have "shared", "invar", "complete" or "<>" attribute'//& ' outside of a parallel context') endif endif @@ -8109,6 +8252,7 @@ subroutine make_full_call(coder,cblock,node,procs,& call code_val(coder,procs) call code_num(coder,iflag) call code_null(coder) + call code_val(coder,cnode_get(cblock,cblock_last_call)) call code_num(coder,nret) call code_num(coder,nkeys) coder%index=coder%index+1 @@ -8381,15 +8525,15 @@ end subroutine pushdown_code !====================================================== ! Swap top 2 items on the stack with single item below - ! ... a b c -> ... c a b + ! ... a b c -> ... b c a !====================================================== subroutine swap_code_2_1(coder) type(code_state),intent(inout):: coder type(pm_ptr):: temp temp=coder%vstack(coder%vtop) - coder%vstack(coder%vtop)=coder%vstack(coder%vtop-1) - coder%vstack(coder%vtop-1)=coder%vstack(coder%vtop-2) - coder%vstack(coder%vtop-2)=temp + coder%vstack(coder%vtop)=coder%vstack(coder%vtop-2) + coder%vstack(coder%vtop-2)=coder%vstack(coder%vtop-1) + coder%vstack(coder%vtop-1)=temp end subroutine swap_code_2_1 !================================= @@ -8483,7 +8627,6 @@ function top_word(coder) result(k) k=coder%wstack(coder%wtop) end function top_word - !===================================== ! Dump a cnode tree (debugging) @@ -8621,9 +8764,15 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) write(iunit,*) spaces(1:depth*2),')' case(cnode_is_builtin) - write(iunit,*) spaces(1:depth*2),'Builtin ',& - op_names(cnode_get_num(node,cnode_args)),& - cnode_get_num(node,cnode_args+1),'(' + if(cnode_get_num(node,cnode_args)>=0) then + write(iunit,*) spaces(1:depth*2),'Builtin ',& + op_names(cnode_get_num(node,cnode_args)),& + cnode_get_num(node,cnode_args+1),'(' + else + write(iunit,*) spaces(1:depth*2),'Fold ',& + (cnode_get_num(node,cnode_args)),& + cnode_get_num(node,cnode_args+1),'(' + endif if(.not.pm_fast_isnull(cnode_get(node,bi_rcode))) then call qdump_code_tree(coder,rvec,iunit,& cnode_get(node,bi_rcode),depth+1) diff --git a/src/deadcode.f90 b/src/deadcode.f90 index 07f3af6..27bd361 100644 --- a/src/deadcode.f90 +++ b/src/deadcode.f90 @@ -170,5 +170,73 @@ subroutine dce_call(coder,callnode,rvec,alive,nested,eliminate) call_noop_flag endif end subroutine dce_call + + + recursive subroutine atree_union(a,b,c,nc) + integer,dimension(:),intent(in):: a,b + integer,dimension(*),intent(out):: c + integer,intent(inout):: nc + integer:: i,j,k,na,nb,nnc + na=countof(a(1)) + nb=countof(b(1)) + i=1 + j=1 + k=0 + do while(i<=na.and.j<=nb) + if(a(i)==b(j)) then + call push(combine(a(i),b(j)) + i=i+1 + j=j+1 + if(a(i)<0) then + if(b(j)<0) then + k=k+1 + nnc=nc-k + call atree_add(a(i:),b(j:),c(k+1:),nnc) + c(k)=-nnc + k=k+nnc+1 + i=i+countof(a(i)) + j=j+countof(b(j)) + else + i=i+countof(a(i)) + endif + else + if(b(j)<0) then + j-j+countof(b(j)) + endif + endif + elseif(a(i)nc) call pm_panic('Program too complex -- deadcode (atree)') + end subroutine push + + end subroutine atree_union + end module pm_deadcode diff --git a/src/infer.f90 b/src/infer.f90 index 5950195..7b8bf29 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -64,6 +64,7 @@ module pm_infer integer,parameter:: sp_sig_thru=-4_pm_p integer,parameter:: sp_sig_dup=-5_pm_p integer,parameter:: sp_sig_noop=-6_pm_p + integer,parameter:: sp_sig_setval=-7_pm_p ! Special types integer,parameter:: undefined=-1 @@ -571,13 +572,15 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) logical:: isstatic type(pm_type_einfo):: einfo - + ! Check cached type value p=cnode_get(prc,bi_rcode) if(pm_fast_istiny(p)) then + ! Result is type of one of the arguments tv=pm_type_vect(coder%context,atype) tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) rtype=(pm_tv_arg(tv,int(p%offset))) elseif(pm_fast_isnull(p)) then + ! A an actual return type has been specified rtype=cnode_get_num(prc,bi_rtype) if(rtype<0) then ! Cached concrete return type @@ -590,18 +593,10 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) if(isstatic) call cnode_set_num(prc,bi_rtype,int(-rtype)) endif endif - if(cnode_get_num(prc,bi_rsym)==sym_dash) then - tv=pm_type_vect(coder%context,atype) - do i=1,pm_tv_numargs(tv) - tv2=pm_type_vect(coder%context,pm_tv_arg(tv,i)) - if(pm_tv_kind(tv2)/=pm_type_is_value) goto 20 - enddo - call fold - if(pm_is_compiling) then - call code_num(coder,sp_sig_noop) - return - endif -20 continue + if(cnode_get_num(prc,bi_opcode)<0) then + rtype=fold(coder,prc,atype,rtype) + call code_num(coder,sp_sig_setval) + goto 10 endif else ! Process code for return expression to get base return type @@ -609,11 +604,12 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) call prc_cblock(coder,cnode_get(prc,bi_rcode),base) rtype=coder%stack(base) call pop_stack_frame(coder,base) - + + ! Special processing of return type + ! Specified by special character in return spec sym=cnode_get_num(prc,bi_rsym) if(rtype/=error_type) then - ! Special processing of return type - ! Specified by special character in return spec + select case(sym) case(sym_hash,sym_pct) tv=pm_type_vect(coder%context,rtype) @@ -671,14 +667,14 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) tv=pm_type_vect(coder%context,rtype) rtype=pm_new_arr_type(coder%context,sym_var,& pm_tv_arg(tv,1),pm_tv_arg(tv,2),int(pm_long)) - case(sym_invar_dim) - tv=pm_type_vect(coder%context,rtype) - rtype=pm_new_arr_type(coder%context,sym_invar,& - pm_tv_arg(tv,1),pm_tv_arg(tv,2),int(pm_long)) - case(sym_fix_dim) - tv=pm_type_vect(coder%context,rtype) - rtype=pm_new_arr_type(coder%context,sym_fix,& - pm_tv_arg(tv,1),pm_tv_arg(tv,2),pm_tv_arg(tv,3)) +!!$ case(sym_invar_dim) +!!$ tv=pm_type_vect(coder%context,rtype) +!!$ rtype=pm_new_arr_type(coder%context,sym_invar,& +!!$ pm_tv_arg(tv,1),pm_tv_arg(tv,2),int(pm_long)) +!!$ case(sym_fix_dim) +!!$ tv=pm_type_vect(coder%context,rtype) +!!$ rtype=pm_new_arr_type(coder%context,sym_fix,& +!!$ pm_tv_arg(tv,1),pm_tv_arg(tv,2),pm_tv_arg(tv,3)) case(sym_over) tv=pm_type_vect(coder%context,rtype) tv2=pm_type_vect(coder%context,pm_tv_arg(tv,1)) @@ -689,9 +685,9 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) t1=pm_tv_arg(tv,1) t2=pm_tv_arg(tv,2) if(pm_type_equal(coder%context,t1,t2)) then - rtype=(coder%true_name) + rtype=(coder%true_fix) else - rtype=(coder%false_name) + rtype=(coder%false_fix) endif case(sym_caret) rtype=(int(pm_tiny_int)) @@ -704,9 +700,9 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) tv=pm_type_vect(coder%context,t2) t2=pm_tv_arg(tv,1) if(pm_type_includes(coder%context,t1,t2,pm_type_incl_type,einfo)) then - rtype=(coder%true_name) + rtype=(coder%true_fix) else - rtype=(coder%false_name) + rtype=(coder%false_fix) endif case(sym_type) tv=pm_type_vect(coder%context,rtype) @@ -715,6 +711,12 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) case(sym_query) rtype=error_type coder%num_errors=coder%num_errors+1 + case(sym_tilde) + tv=pm_type_vect(coder%context,rtype) + t1=pm_tv_arg(tv,1) + tv=pm_type_vect(coder%context,t1) + t1=pm_tv_arg(tv,1) + rtype=pm_new_type_type(coder%context,t1) end select endif endif @@ -724,6 +726,8 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) coder%proc_cache,key,1,prc) call code_num(coder,k) +10 continue + ! Pass out taint information coder%proc_taints=iand(proc_taints,cnode_get_num(prc,bi_flags)) coder%taints=ior(coder%taints,coder%proc_taints) @@ -731,47 +735,7 @@ function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) include 'fisnull.inc' include 'fistiny.inc' include 'fnew.inc' - include 'fvkind.inc' - - ! Compile time computation of expressions - subroutine fold - integer:: i,n,errno - type(pm_ptr):: arg1,arg2 - type(pm_ptr):: result - logical:: ok - character(len=100):: emess - type(pm_ptr):: rtv - integer:: rtyp - n=pm_tv_numargs(tv) - arg1=pm_dict_val(coder%context,coder%context%tcache,& - int(pm_tv_arg(tv,1),pm_ln)) - if(n>1) then - arg2=pm_dict_val(coder%context,coder%context%tcache,& - int(pm_tv_arg(tv,2),pm_ln)) - endif - rtv=pm_type_vect(coder%context,rtype) - rtyp=pm_tv_arg(rtv,1) - if(rtyp/=pm_logical) then - coder%temp=pm_fast_new(coder%context,int(rtyp,pm_p),1_pm_p) - call fold_value(cnode_get_num(prc,bi_opcode),& - coder%temp,arg1,arg2,ok,emess) - if(.not.ok) then - call infer_error_with_trace(coder,prc,& - 'Cannot combine run time values: '//trim(emess)) - else - rtype=(pm_new_value_type(coder%context,coder%temp)) - endif - else - call fold_comparison(cnode_get_num(prc,bi_opcode),arg1,arg2,ok) - if(ok) then - rtype=(coder%true_name) - else - rtype=(coder%false_name) - endif - endif - coder%temp=pm_null_obj - end subroutine fold - + include 'fvkind.inc' end function prc_builtin !========================================== @@ -831,6 +795,7 @@ subroutine prc_call(coder,cblock,callnode,base) ! call (with symbol sig) select case(sig) case(sym_while) + call check_loop_writes(5) list=cnode_arg(args,2) list2=cnode_arg(args,4) counter=0 @@ -839,7 +804,7 @@ subroutine prc_call(coder,cblock,callnode,base) call clear_cblock_mark(list2) call prc_cblock(coder,list,base) call check_logical(3) - if(arg_type(3)==coder%false_name) return + if(arg_type(3)==coder%false_fix) return call prc_cblock(coder,list2,base) if(.not.(cblock_marked(list).or.& cblock_marked(list2))) exit @@ -857,6 +822,7 @@ subroutine prc_call(coder,cblock,callnode,base) call set_call_sig(0) endif case(sym_until,sym_each) + call check_loop_writes(4) list=cnode_arg(args,2) counter=0 do @@ -877,16 +843,7 @@ subroutine prc_call(coder,cblock,callnode,base) call set_call_sig(0) endif case(sym_if,sym_if_invar) - call check_logical(1) - tno=arg_type(1) - list=cnode_arg(args,2) - if(tno/=coder%false_name) then - call prc_cblock(coder,list,base) - endif - list=cnode_arg(args,3) - if(tno/=coder%true_name) then - call prc_cblock(coder,list,base) - endif + call prc_if(nargs) case(sym_do,sym_for,sym_also) call prc_cblock(coder,cnode_arg(args,1),base) case(sym_sync) @@ -896,23 +853,30 @@ subroutine prc_call(coder,cblock,callnode,base) call prc_cblock(coder,cnode_arg(args,2),base) case(sym_import_val,sym_import_param) tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) - mode=merge(sym_shared,sym_mirrored,& - iand(pm_type_flags(coder%context,tno),& - pm_type_has_distributed)/=0) - coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,& - mode,.false.) - if(tno>0.and.coder%par_kind==par_mode_conc.and.mode==sym_shared) then - if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then - call infer_error_with_trace(coder,callnode,& - 'Cannot import distributed value into mirrored "forall"') - coder%stack(get_slot(1))=error_type + if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then + call infer_error_with_trace(coder,callnode,& + 'Cannot import uninitialised value into a nested parallel context:',& + cnode_get(cnode_arg(args,2),var_name)) + coder%stack(get_slot(1))=error_type + else + mode=merge(sym_shared,sym_mirrored,& + iand(pm_type_flags(coder%context,tno),& + pm_type_has_distributed)/=0) + coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,& + mode,.false.) + if(tno>0.and.coder%par_kind==par_mode_conc.and.mode==sym_shared) then + if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then + call infer_error_with_trace(coder,callnode,& + 'Cannot import distributed value into mirrored "forall"') + coder%stack(get_slot(1))=error_type + endif endif +!!$ write(*,*) 'import to',trim(pm_name_as_string(coder%context,& +!!$ cnode_get_num(cnode_arg(args,1),var_name))),coder%stack(get_slot(1)),tno,& +!!$ cnode_get_num(cnode_arg(args,2),var_index),cnode_get_num(cnode_arg(args,1),var_index),& +!!$ coder%stack(86),get_slot(1) + call flag_import_export(tno) endif - write(*,*) 'import to',trim(pm_name_as_string(coder%context,& - cnode_get_num(cnode_arg(args,1),var_name))),coder%stack(get_slot(1)),tno,& - cnode_get_num(cnode_arg(args,2),var_index),cnode_get_num(cnode_arg(args,1),var_index),& - coder%stack(86),get_slot(1) - call flag_import_export(tno) case(sym_import_varg) tno=arg_type(2) if(tno>0) then @@ -1225,15 +1189,20 @@ subroutine prc_call(coder,cblock,callnode,base) namep=cnode_arg(cnode_arg(args,3),1) name=namep%offset endif - tno=pm_type_strip_mode_and_cond(coder%context,& - arg_type_with_mode(2),mode,cond) - if(tno>0) then - call set_call_sig(resolve_elem(tno,name,& - sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) - call combine_types(cnode_arg(args,1),& - pm_type_add_mode(coder%context,tno2,mode,cond)) - else + tno=arg_type_with_mode(2) + if(tno==error_type) then call set_arg_to_error_type(1) + else + tno=pm_type_strip_mode_and_cond(coder%context,& + tno,mode,cond) + if(tno>0) then + call set_call_sig(resolve_elem(tno,name,& + sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) + call combine_types(cnode_arg(args,1),& + pm_type_add_mode(coder%context,tno2,mode,cond)) + else + call set_arg_to_error_type(1) + endif endif case(sym_method_call) tno=arg_type(2) @@ -1298,6 +1267,18 @@ subroutine prc_call(coder,cblock,callnode,base) call infer_error_with_trace(coder,callnode,& 'Expression must be invariant instead of: '//trim(sym_names(mode))) endif + case(sym_var) + tno=cnode_num_arg(args,nargs+nret) + do i=1,nret + call set_arg_to_type(i,tno) + enddo + case(sym_const) + tno=arg_type(1) + if(pm_type_kind(coder%context,tno)/=pm_type_is_uninitialised) then + call infer_error(coder,callnode,& + 'Cannot initialise constant twice in succession: ',& + cnode_get(cnode_arg(args,1),var_name)) + endif case(sym_assignment) tno=pm_type_get_mode(coder%context,arg_type_with_mode(1)) if(tno>=sym_mirrored) then @@ -1433,19 +1414,20 @@ subroutine prc_call(coder,cblock,callnode,base) endif call prc_cblock(coder,cnode_arg(args,4),base) tno=arg_type(3) - if(arg_type(1)/=pm_string_type.and.arg_type(1)/=error_type) then + if(pm_type_strip_to_basic(coder%context,arg_type(1))/=pm_string_type& + .and.arg_type(1)/=error_type) then call infer_error_with_trace(coder,cnode_arg(args,1),& 'Check message is not a string, got:'//& trim(pm_type_as_string(coder%context,arg_type(1)))) - elseif(tno==coder%false_name) then + elseif(tno==coder%false_fix) then if(cnode_get_kind(cnode_arg(args,1))==cnode_is_const) then call pm_strval(cnode_arg(cnode_arg(args,1),1),str) - call infer_error_with_trace(coder,callnode,str(1:len_trim(str)-1)) + call infer_error_with_trace(coder,callnode,str(1:len_trim(str))) else call infer_error_with_trace(coder,callnode,& 'Check condition will always fail') endif - elseif(tno/=coder%true_name) then + elseif(tno/=coder%true_fix) then call check_logical(3) coder%stack(base-2)=ior(coder%stack(base-2),proc_is_impure) endif @@ -1456,6 +1438,10 @@ subroutine prc_call(coder,cblock,callnode,base) call infer_error_with_trace(coder,callnode,& 'Value after '' cannot be determined at compile time') endif + if(pm_tv_kind(t)==pm_type_is_literal) then + tno=pm_new_fix_type(coder%context,pm_type_val(coder%context,tno),& + pm_tv_name(t)) + endif coder%stack(get_slot(1))=tno case(sym_dcaret) coder%stack(get_slot(1))=pm_type_add_mode(coder%context,& @@ -1593,6 +1579,35 @@ subroutine prc_call(coder,cblock,callnode,base) include 'ftiny.inc' include 'ftypeno.inc' + subroutine prc_if(nargs) + integer,intent(in):: nargs + integer,dimension(4:nargs):: save_args + integer:: i,tno,typ + call check_logical(1) + tno=arg_type(1) + if(tno/=coder%false_fix) then + if(tno==coder%true_fix.or.pm_fast_isnull(cnode_arg(args,3))) then + call prc_cblock(coder,cnode_arg(args,2),base) + else + do i=4,nargs + save_args(i)=arg_type_with_mode(i) + end do + call prc_cblock(coder,cnode_arg(args,2),base) + do i=4,nargs + typ=save_args(i) + save_args(i)=arg_type_with_mode(i) + call set_arg_to_type(i,typ) + end do + call prc_cblock(coder,cnode_arg(args,3),base) + do i=4,nargs + call combine_arg_types(i,save_args(i),no_init=.true.) + end do + endif + else + call prc_cblock(coder,cnode_arg(args,3),base) + endif + end subroutine prc_if + !=================================================================== ! Push argument types with modes for all arguments !================================================================== @@ -1626,14 +1641,14 @@ function arg_type_with_mode(m) result(tno) if(tno==undefined) then call qdump_code_tree(coder,pm_null_obj,6,& cnode_arg(args,m),2) - call infer_error_with_trace(coder,args,'Internal Compiler Error: Broken type resulution::') + call infer_error_with_trace(coder,args,& + 'Internal Compiler Error: Broken type resulution::') !!call pm_panic('Broken type resolution chain') endif endif endif end function arg_type_with_mode - !=================================================================== ! Return the type for argument m (errors are checked) !================================================================== @@ -1643,7 +1658,6 @@ function arg_type(m) result(tno) integer:: mode tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) end function arg_type - !=================================================================== ! Return the type and mode for arguement m (no error check) @@ -1691,7 +1705,8 @@ subroutine get_slot_and_type(m,slot,tno) tno=coder%stack(slot) if(pm_debug_checks) then if(tno==undefined) then - call infer_error_with_trace(coder,args,'Internal Compiler Error: Broken type resulution::') + call infer_error_with_trace(coder,args,& + 'Internal Compiler Error: Broken type resulution::') endif endif endif @@ -1724,8 +1739,8 @@ subroutine check_logical(m) integer:: tno tno=arg_type(m) if(tno/=error_type) then - if(tno/=pm_logical.and.& - tno/=coder%true_name.and.tno/=coder%false_name) then + if(tno/=pm_logical.and.tno/=coder%true_literal.and.tno/=coder%false_literal.and.& + tno/=coder%true_fix.and.tno/=coder%false_fix) then call infer_error_with_trace(coder,callnode,& 'Expecting boolean expression, got: '//& trim(pm_type_as_string(coder%context,tno))) @@ -1752,6 +1767,24 @@ subroutine check_long(m) endif endif end subroutine check_long + + !======================================================================= + ! Check that arguments arg1..nargs of a loop call are not uninitialised + ! (these are in-loop writes) + !======================================================================= + subroutine check_loop_writes(arg1) + integer,intent(in):: arg1 + integer:: i + do i=arg1,nargs + if(pm_type_kind(coder%context,arg_type(i))==pm_type_is_uninitialised) then + call infer_error(coder,callnode,& + 'A variable cannot be uninitialised at the start of a loop that changes it:',& + cnode_get(cnode_arg(args,i),var_name)) + call infer_error(coder,cnode_arg(args,i),'Declaration corresponding to the above') + call set_arg_to_error_type(i) + endif + enddo + end subroutine check_loop_writes subroutine clear_cblock_mark(list) type(pm_ptr),intent(in):: list @@ -1822,12 +1855,17 @@ recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) endif elseif(sig==0) then if(.not.isopt) then - call infer_error_with_trace(coder,callnode,& - 'Error accessing element "'//& - trim(pm_name_as_string(coder%context,name))//& - '" of type "'//& - trim(pm_type_as_string(coder%context,tno))//'"') - call pm_type_error(coder%context,einfo) + if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then + call infer_error(coder,callnode,& + 'Cannot take element of an uninitialised value') + else + call infer_error_with_trace(coder,callnode,& + 'Error accessing element "'//& + trim(pm_name_as_string(coder%context,name))//& + '" of type "'//& + trim(pm_type_as_string(coder%context,tno))//'"') + call pm_type_error(coder%context,einfo) + endif endif elem_type=error_type endif @@ -1835,7 +1873,19 @@ recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) end function resolve_elem !================================================================== - ! Set argument m to have error type + ! Set argument m (which must be a var) to have type t + ! - overwrites original -- generally use combine_types + !================================================================== + subroutine set_arg_to_type(m,t) + integer:: m,t + integer:: slot + type(pm_ptr):: ptr + slot=get_slot(m) + coder%stack(slot)=t + end subroutine set_arg_to_type + + !================================================================== + ! Set argument m (which must be a var) to have error type !================================================================== subroutine set_arg_to_error_type(m) integer:: m @@ -1848,9 +1898,19 @@ end subroutine set_arg_to_error_type !================================================================== ! Augment the type stored in a given variable vararg by adding typ !================================================================== - subroutine combine_types(vararg,typ) + subroutine combine_arg_types(m,typ,no_init) + integer,intent(in):: m,typ + logical,intent(in),optional:: no_init + call combine_types(cnode_arg(args,m),typ,no_init=no_init) + end subroutine combine_arg_types + + !=================================================================== + ! Augment the type stored in a given variable vararg by adding typ + !================================================================== + subroutine combine_types(vararg,typ,no_init) type(pm_ptr),intent(in)::vararg integer,intent(in):: typ + logical,intent(in),optional:: no_init integer:: slot integer:: typ0,n type(pm_ptr):: tv,p,q,var @@ -1862,19 +1922,40 @@ subroutine combine_types(vararg,typ) endif slot=base+cnode_get_num(var,var_index) typ0=coder%stack(slot) - if(typ0<0) then - coder%stack(slot)=typ - elseif(typ/=typ0.and.typ/=error_type.and.typ0/=error_type.and.& - coder%num_errors==0) then - call cnode_error(coder,var,'Variable changed type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - trim(pm_type_as_string(coder%context,typ))//' <> '//& - trim(pm_type_as_string(coder%context,typ0))) + coder%stack(slot)=typ + if(typ/=typ0.and.typ0>0) then + if(typ0==error_type) then + coder%stack(slot)=typ0 + elseif(typ/=error_type.and.& + (present(no_init).or.& + pm_type_kind(coder%context,typ0)/=pm_type_is_uninitialised).and.& + coder%num_errors==0) then + if(pm_type_kind(coder%context,typ0)==pm_type_is_uninitialised.or.& + pm_type_kind(coder%context,typ)==pm_type_is_uninitialised) then + call cnode_error(coder,callnode,& + 'Variable/constant is not intialised in all branches of a conditional statment:',& + cnode_get(var,var_name)) + else + call cnode_error(coder,var,'Value does not have consistent type:',& + cnode_get(var,var_name)) + call more_error(coder%context,& + 'First: '//trim(pm_type_as_string(coder%context,typ0))) + call more_error(coder%context,& + 'Then: '//trim(pm_type_as_string(coder%context,typ))) + if(present(no_init)) then + call cnode_error(coder,callnode,& + 'Above type is inconsistent between branches of this statement') + else + call cnode_error(coder,callnode,'Type inconsistency occurs here') + endif + endif + endif endif end subroutine combine_types + + end subroutine prc_call !================================================================== @@ -2209,9 +2290,10 @@ end subroutine set_arg_to_error_type !=================================================================== ! Augment the type stored in a given variable vararg by adding typ !================================================================== - subroutine combine_types(vararg,typ) + subroutine combine_types(vararg,typ,no_init) type(pm_ptr),intent(in)::vararg integer,intent(in):: typ + logical,intent(in),optional:: no_init integer:: slot integer:: typ0,n type(pm_ptr):: tv,p,q,var @@ -2223,15 +2305,34 @@ subroutine combine_types(vararg,typ) endif slot=base+cnode_get_num(var,var_index) typ0=coder%stack(slot) - if(typ0<0) then - coder%stack(slot)=typ - elseif(typ/=typ0.and.typ/=error_type.and.typ0/=error_type.and.& - coder%num_errors==0) then - call cnode_error(coder,var,'Variable changed type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - trim(pm_type_as_string(coder%context,typ))//' <> '//& - trim(pm_type_as_string(coder%context,typ0))) + coder%stack(slot)=typ + if(typ/=typ0.and.typ0>0) then + if(typ0==error_type) then + coder%stack(slot)=typ0 + elseif(typ/=error_type.and.& + (present(no_init).or.& + pm_type_kind(coder%context,typ0)/=pm_type_is_uninitialised).and.& + coder%num_errors==0) then + if(pm_type_kind(coder%context,typ0)==pm_type_is_uninitialised.or.& + pm_type_kind(coder%context,typ)==pm_type_is_uninitialised) then + call cnode_error(coder,callnode,& + 'Variable is not intialised in all branches of a conditional statment:',& + cnode_get(var,var_name)) + else + call cnode_error(coder,var,'Variable changes type:',& + cnode_get(var,var_name)) + call more_error(coder%context,& + 'From: '//trim(pm_type_as_string(coder%context,typ0))) + call more_error(coder%context,& + 'To: '//trim(pm_type_as_string(coder%context,typ))) + if(present(no_init)) then + call cnode_error(coder,callnode,& + 'Type change occurs between branches of this statement') + else + call cnode_error(coder,callnode,'Type change occurs here') + endif + endif + endif endif end subroutine combine_types @@ -2398,13 +2499,13 @@ end subroutine check_call_against_sig ! procedure matching process ! - If issig is present then disable visibility rule (for "." call) !======================================================================== - function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) + function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(ressig) integer,intent(in):: sig type(pm_ptr),intent(in):: procs logical,intent(out),optional:: err integer,intent(in),optional:: sigpars,sigtyp logical,intent(in),optional:: issig - integer:: k + integer:: ressig integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass integer:: vbase,wbase @@ -2441,9 +2542,10 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) ! This is done in multiple passes with broader matching allowed in pass 2 if(pm_debug_level>4) write(*,*) 'Checking',cnode_numargs(procs),' sigs' found=.false. + apars=error_type ! For procedure signature "." call then don't check visibility visible=present(issig) - do jpass=0,3 + outer: do jpass=0,3 if(debug_inference) write(*,*) 'MATCH PASS> ',jpass do i=3,cnode_numargs(procs),2 pars=cnode_num_arg(procs,i) @@ -2473,7 +2575,7 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) wbase=coder%wtop vbase=coder%vtop apars=check_call_sig(coder,callnode,cnode_arg(procs,i+1),& - mpars,nargs-nkey,nextra,jpass) + mpars,nargs-nkey,nextra,cnode_get_num(callnode,call_flags),jpass) if(apars>=0) then ! Check for a visible match @@ -2526,7 +2628,6 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) endif endif - ! A good match has been found ! infer the associated procedure found=.true. @@ -2563,7 +2664,7 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) coder%vtop=start coder%proc_key_base=save_proc_key_base coder%wtop=wbase - k=1234567 + ressig=1234567 return else if(coder%vtop/=pcheck+1) call pm_panic('pcheck mismatch') @@ -2588,6 +2689,9 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) enddo endif endif + elseif(apars==error_type) then + if(debug_inference) write(*,*) 'TERMINATED>' + exit outer else ! Not this one - keep looking coder%vtop=vbase @@ -2597,13 +2701,18 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) if(debug_inference) write(*,*) 'CHECKED SIG' enddo if(found) exit - enddo + enddo outer if(debug_inference) then write(*,*) 'ALL SIGS CHECKED>',trim(sig_name_str(coder,int(sig))) endif - if(.not.found.or..not.visible) then + if(apars==error_type) then + do i=1,nret + call set_arg_to_error_type(i) + enddo + ressig=undefined + elseif(.not.found.or..not.visible) then ! If nothing found print error message ! or return error flag if(.not.present(err)) then @@ -2640,7 +2749,7 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) do i=1,nret call set_arg_to_error_type(i) enddo - k=undefined + ressig=undefined else err=.true. endif @@ -2650,9 +2759,9 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) call make_code(coder,pm_null_obj,cnode_is_autoconv_sig,& coder%vtop-start) key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,key,1,top_code(coder)) + ressig=pm_idict_add(coder%context,coder%proc_cache,key,1,top_code(coder)) else - k=coder%vstack(coder%vtop)%offset + ressig=coder%vstack(coder%vtop)%offset endif endif @@ -2852,14 +2961,14 @@ end function add_poly_to_poly ! Find procedure matching a given call signature ! Call argument types must be on wstack !==================================================== - function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result(tno) + function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,flags,ipass) result(tno) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,matchnode integer,intent(in):: pars - integer,intent(in):: nargs,ignore,ipass + integer,intent(in):: nargs,ignore,flags,ipass integer:: tno integer:: at,at2,pt,pt2,slot - type(pm_ptr):: pv,amb,av,vec + type(pm_ptr):: pv,amb,av,vec,args integer:: i,rel,n,base,wbase,pk,pk2,dbase,status logical:: ok type(pm_type_einfo):: einfo @@ -2920,6 +3029,23 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result else pt=pm_tv_arg(pv,i-ignore) endif + if(pm_type_kind(coder%context,at)==pm_type_is_uninitialised) then + if(iand(flags,call_is_uninitialised)/=0) then + at=pm_type_arg(coder%context,at,1) + else + call cnode_error(coder,callnode,& + 'Attempt to use "var" or "const" value before it is initialised') + args=cnode_get(callnode,call_args) + call cnode_error(coder,cnode_arg(args,i),& + 'Definition statement relating to above error') + tno=error_type + goto 10 + endif + endif + if(iand(flags,call_is_fixed)==0) then + at2=pm_type_convert(coder%context,pt,at,.true.,.false.,.false.) + if(at2>0) at=at2 + endif if(pm_type_includes(coder%context,& pt,at,pm_type_incl_val,einfo)) then coder%wstack(wbase+i+2)=at @@ -2933,8 +3059,8 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result 'Ambiguous match to proc definition ( match in multiple alternatives)') call cnode_error(coder,callnode,'... call being processed') elseif(ipass>=1) then - pt2=pm_type_strip_to_basic(coder%context,pt) - at2=pm_type_convert(coder%context,pt2,at,.false.) + !pt2=pm_type_strip_to_basic(coder%context,pt) + at2=pm_type_convert(coder%context,pt,at,.false.,.true.,.false.) if(at2/=undefined) then coder%wstack(wbase+2+i)=at2 goto 5 @@ -3020,7 +3146,7 @@ subroutine ambiguous_match_error(coder,callnode,pt,at,at2) type(pm_ptr):: callnode integer,intent(in):: pt,at,at2 call infer_error(coder,callnode,'Ambiguous match to embedded value:') - call typ_ambiguous_match_error(coder%context,pt,at,at2,coder%wstack,coder%wtop) + call pm_type_ambiguous_match_error(coder%context,pt,at,at2,coder%wstack,coder%wtop) call infer_trace(coder) end subroutine ambiguous_match_error @@ -3045,7 +3171,7 @@ function prc_cast(coder,node,tno1,tno2,isvar) result(k) einfo) if(.not.ok) then tno1b=pm_type_strip_to_basic(coder%context,tno1) - tno3=pm_type_convert(coder%context,tno1b,tno2,.true.) + tno3=pm_type_convert(coder%context,tno1b,tno2,.true.,.true.,.false.) if(tno3==undefined) then base=coder%wtop call pm_indirect_include(coder%context,tno1,tno2,& @@ -3093,6 +3219,85 @@ function prc_cast(coder,node,tno1,tno2,isvar) result(k) include 'fisnull.inc' end function prc_cast + !============================================= + ! Compile time computation of expressions + ! atype - tuple of argument types + ! rstypes - typle of declared result types + ! rtype - actual result type + !============================================= + function fold(coder,prc,atype,rstype) result(rtype) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: prc + integer,intent(in):: atype,rstype + integer:: rtype + integer:: i,n,opcode,errno + type(pm_ptr):: tv,arg1,arg2 + type(pm_ptr):: result + logical:: ok + character(len=100):: emess + type(pm_ptr):: rtv + integer:: rtyp + + tv=pm_type_vect(coder%context,atype) + n=pm_tv_numargs(tv) + opcode=cnode_get_num(prc,bi_opcode) + arg1=pm_dict_val(coder%context,coder%context%tcache,& + int(pm_tv_arg(tv,1),pm_ln)) + if(n>1) then + arg2=pm_dict_val(coder%context,coder%context%tcache,& + int(pm_tv_arg(tv,2),pm_ln)) + endif + rtyp=pm_type_strip_to_basic(coder%context,pm_type_arg(coder%context,rstype,1)) + rtv=pm_type_vect(coder%context,rtyp) + rtyp=pm_type_strip_to_basic(coder%context,pm_tv_arg(rtv,1)) + !write(*,*) rtyp,'rtyp=',trim(pm_type_as_string(coder%context,rtyp)) + if(rtyp==pm_long) then + coder%temp=pm_fast_newnc(coder%context,pm_long,1) + call fold_value(opcode,coder%temp,arg1,arg2,ok,emess) + if(.not.ok) then + call infer_error_with_trace(coder,prc,& + 'Cannot combine run time values: '//trim(emess)) + elseif(pm_tv_kind(rtv)==pm_type_is_unfixed) then + rtype=pm_new_literal_type(coder%context,coder%temp) + else + rtype=pm_new_fix_type(coder%context,coder%temp) + endif + elseif(rtyp==pm_string_type) then + call fold_string(coder,opcode,arg1,arg2,coder%temp) + write(*,*) 'fold str' + if(pm_tv_kind(rtv)==pm_type_is_unfixed) then + rtype=pm_new_literal_type(coder%context,coder%temp) + else + rtype=pm_new_fix_type(coder%context,coder%temp) + endif + else + if(opcode==op_eq_fold.or.opcode==op_ne_fold) then + ok=pm_type_name(coder%context,pm_tv_arg(tv,1))==& + pm_type_name(coder%context,pm_tv_arg(tv,2)) + if(opcode==op_ne_fold) ok=.not.ok + else + call fold_comparison(opcode,arg1,arg2,ok) + endif + if(pm_tv_kind(rtv)==pm_type_is_unfixed) then + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + else + if(ok) then + rtype=coder%true_fix + else + rtype=coder%false_fix + endif + endif + endif + coder%temp=pm_null_obj + contains + include "fnewnc.inc" + end function fold + + !=========================================================== ! Calculate and arithmetic operation on integer constants !=========================================================== @@ -3103,51 +3308,51 @@ subroutine fold_value(op,a,b,c,ok,emess) character(len=*),intent(out):: emess ok=.true. select case(op) - case(op_uminus_ln) + case(op_uminus_fold) a%data%ln(a%offset)=-b%data%ln(b%offset) - case(op_add_ln) + case(op_add_fold) a%data%ln(a%offset)=b%data%ln(b%offset)+c%data%ln(c%offset) - case(op_sub_ln) + case(op_sub_fold) a%data%ln(a%offset)=b%data%ln(b%offset)-c%data%ln(c%offset) - case(op_mult_ln) + case(op_mult_fold) a%data%ln(a%offset)=b%data%ln(b%offset)*c%data%ln(c%offset) - case(op_divide_ln) + case(op_divide_fold) if(c%data%ln(c%offset)/=0) then a%data%ln(a%offset)=b%data%ln(b%offset)/c%data%ln(c%offset) else ok=.false. emess='division by zero' endif - case(op_mod_ln) + case(op_mod_fold) if(c%data%ln(c%offset)/=0) then a%data%ln(a%offset)=modulo(b%data%ln(b%offset),c%data%ln(c%offset)) else ok=.false. emess='modulo zero' endif - case(op_pow_ln) + case(op_pow_fold) a%data%ln(a%offset)=b%data%ln(b%offset)**c%data%ln(c%offset) - case(op_max_ln) + case(op_max_fold) a%data%ln(a%offset)=max(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_min_ln) + case(op_min_fold) a%data%ln(a%offset)=min(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_abs_ln) + case(op_abs_fold) a%data%ln(a%offset)=abs(b%data%ln(b%offset)) - case(op_band_ln) + case(op_band_fold) a%data%ln(a%offset)=iand(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bor_ln) + case(op_bor_fold) a%data%ln(a%offset)=ior(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bxor_ln) + case(op_bxor_fold) a%data%ln(a%offset)=ieor(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bshift_ln) + case(op_bshift_fold) a%data%ln(a%offset)=ishft(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bnot_ln) + case(op_bnot_fold) a%data%ln(a%offset)=not(b%data%ln(b%offset)) - case(op_pdiff_ln) + case(op_pdiff_fold) a%data%ln(a%offset)=dim(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_sign_ln) + case(op_sign_fold) a%data%ln(a%offset)=sign(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_modulo_ln) + case(op_modulo_fold) if(c%data%ln(c%offset)/=0) then a%data%ln(a%offset)=mod(b%data%ln(b%offset),c%data%ln(c%offset)) else @@ -3157,22 +3362,46 @@ subroutine fold_value(op,a,b,c,ok,emess) end select end subroutine fold_value + !================================================= + ! Calculate operations returning string constants + !================================================= + subroutine fold_string(coder,op,a,b,c) + type(code_state),intent(inout):: coder + integer,intent(in):: op + type(pm_ptr),intent(in):: a,b + type(pm_ptr),intent(out):: c + character(len=100):: str + select case(op) + case(op_string_fold) + str=pm_number_as_string(coder%context,a,0_pm_ln) + c=pm_new_string(coder%context,trim(str)) + case(op_concat_fold) + c=pm_concat_string(coder%context,a,b) + end select + end subroutine fold_string + !=============================================== - ! Calculate logical operation on bool constants + ! Calculate operations returning bool constants !=============================================== subroutine fold_comparison(op,a,b,ok) integer,intent(in):: op type(pm_ptr),intent(in):: a,b logical,intent(out):: ok select case(op) - case(op_gt_ln) + case(op_gt_fold) ok=a%data%ln(a%offset)>b%data%ln(b%offset) - case(op_ge_ln) + case(op_ge_fold) ok=a%data%ln(a%offset)>=b%data%ln(b%offset) - case(op_eq_ln) + case(op_eq_fold) ok=a%data%ln(a%offset)>=b%data%ln(b%offset) - case(op_ne_ln) + case(op_ne_fold) ok=a%data%ln(a%offset)/=b%data%ln(b%offset) + case(op_and_fold) + ok=a%data%l(a%offset).and.b%data%l(b%offset) + case(op_or_fold) + ok=a%data%l(a%offset).or.b%data%l(b%offset) + case(op_except_fold) + ok=a%data%l(a%offset).and..not.b%data%l(b%offset) end select end subroutine fold_comparison diff --git a/src/linker.f90 b/src/linker.f90 index d5a140b..6245f28 100755 --- a/src/linker.f90 +++ b/src/linker.f90 @@ -200,7 +200,7 @@ subroutine link_merge(context,nerror,node,kind,v1,v2) else call pm_ptr_assign(context,& first,& - int(typ_link,pm_ln),& + int(type_link,pm_ln),& v2%data%ptr(v2%offset+node_args+1)) endif call pm_ptr_assign(context,v1,int(node_args+2,pm_ln),& diff --git a/src/memory.f90 b/src/memory.f90 index 8639197..8a3c3fb 100755 --- a/src/memory.f90 +++ b/src/memory.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2016 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -230,6 +230,7 @@ module pm_memory type(pm_ptr),public:: pm_undef_obj,pm_null_obj,pm_tinyint_obj,pm_name_obj type(pm_ptr),public:: pm_typeno_obj,pm_procname_obj,pm_true_obj,pm_false_obj + type(pm_ptr),dimension(pm_int:pm_num_vkind),public:: pm_empty_obj contains @@ -529,30 +530,32 @@ subroutine pm_expand(context,obj,n,newsize) end subroutine pm_expand ! Create a new object - function pm_new(context,vkind,esize) result(ptr) + function pm_new(context,vkind,size) result(ptr) type(pm_context),pointer:: context integer(pm_p),intent(in):: vkind - integer(pm_ln),intent(in):: esize + integer(pm_ln),intent(in):: size type(pm_ptr):: ptr if(pm_debug_level>0) then if(vkindpm_usr) & call pm_panic('New - bad vkind') - if(esize<=0) & - call pm_panic('New - non +ve esize') + if(size<0) & + call pm_panic('New - non +ve size') endif - if(esize<=pm_large_obj_size) then - ptr=pm_new_small(context,vkind,int(esize,pm_p)) + if(size==0) then + ptr=pm_empty_obj(vkind) + elseif(size<=pm_large_obj_size) then + ptr=pm_new_small(context,vkind,int(size,pm_p)) else - ptr=pm_new_large(context,vkind,esize) + ptr=pm_new_large(context,vkind,size) endif end function pm_new ! Create multiple new objects ! -- assign to locations loc,loc+1,...,loc+n-1 in vect - subroutine pm_new_multi(context,vkind,esize,loc,n,vect) + subroutine pm_new_multi(context,vkind,size,loc,n,vect) type(pm_context),pointer:: context integer(pm_p),intent(in):: vkind - integer(pm_ln),intent(in):: loc,n,esize + integer(pm_ln),intent(in):: loc,n,size type(pm_ptr),intent(in):: vect integer(pm_ln):: i,j,k,m type(pm_ptr):: ptr @@ -560,10 +563,10 @@ subroutine pm_new_multi(context,vkind,esize,loc,n,vect) logical:: is_marked context%temp_obj1=vect is_marked=marked(vect) - if(esize<=pm_large_obj_size) then + if(size<=pm_large_obj_size) then i=0 do while(icontext%obj_list(esize,vkind) + ptr_p=>context%obj_list(size,vkind) ptr=ptr_p if(associated(ptr%data)) then if(ptr%offsetpm_add_root(context,ptr) end function pm_new_as_root ! Create a new object of <= pm_large_obj_size elements - function pm_new_small(context,vkind,esize) result(nptr) + function pm_new_small(context,vkind,size) result(nptr) type(pm_context),pointer:: context - integer(pm_p),intent(in):: vkind,esize + integer(pm_p),intent(in):: vkind,size type(pm_ptr):: nptr type(pm_ptr):: ptr type(pm_block),pointer:: oldblk @@ -620,48 +623,49 @@ function pm_new_small(context,vkind,esize) result(nptr) logical:: ok integer:: i - if(gc_xtra_debug) write(*,*) 'ALLOCATE>',vkind,esize + if(gc_xtra_debug) write(*,*) 'ALLOCATE>',vkind,size if(pm_debug_level>0) then if(vkindpm_usr) & call pm_panic('New small - bad vkind') - if(esize<=0.or.esize>pm_large_obj_size) & - call pm_panic('New small - bad esize') + if(size<=0.or.size>pm_large_obj_size) & + call pm_panic('New small - bad size') endif ! Get allocation slot for kind and size if(pm_debug_level>0) then - if(esize<=0) call pm_panic('alloc-esize') + if(size<=0) call pm_panic('alloc-size') endif - ptr_p=>context%obj_list(esize,vkind) + ptr_p=>context%obj_list(size,vkind) ptr=ptr_p if(associated(ptr%data)) then if(ptr%offsetmax_blocks) & - call pm_gc(context,.false.) - ptr%data=>new_block(context,vkind,int(esize,pm_ln)) + if(context%blocks_allocated>max_blocks) then + call pm_gc(context,.false.) + endif + ptr%data=>new_block(context,vkind,int(size,pm_ln)) ptr%offset=1 ptr%data%next=>ptr%data - ptr%data%next_sweep=ptr%data%size-esize+2 + ptr%data%next_sweep=ptr%data%size-size+2 ptr_p%data=>ptr%data - ptr_p%offset=1+esize + ptr_p%offset=1+size nptr=ptr goto 10 endif ! Check if GC has run since last use of this slot if(ptr%data%tickcontext%obj_list(esize,vkind) + ptr_p=>context%obj_list(size,vkind) if(associated(ptr_p%data)) then ptr=ptr_p ptr%offset=1 @@ -689,15 +693,15 @@ function pm_new_small(context,vkind,esize) result(nptr) if(.not.ok) then ! All full - allocate new block - ptr%data=>new_block(context,vkind,int(esize,pm_ln)) + ptr%data=>new_block(context,vkind,int(size,pm_ln)) ptr%offset=1 - ptr%data%next_sweep=ptr%data%size-esize+2 - ptr_p=>context%obj_list(esize,vkind) + ptr%data%next_sweep=ptr%data%size-size+2 + ptr_p=>context%obj_list(size,vkind) if(associated(ptr_p%data)) then ptr%data%next=>ptr_p%data%next ptr_p%data%next=>ptr%data ptr_p%data=>ptr%data - ptr_p%offset=1+esize + ptr_p%offset=1+size else ptr%data%next=>ptr%data endif @@ -713,7 +717,7 @@ function pm_new_small(context,vkind,esize) result(nptr) if(gc_xtra_debug) write(*,*) 'NEXT FREE' ! Find following free location - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size call next_free() if(.not.ok) then @@ -729,15 +733,15 @@ function pm_new_small(context,vkind,esize) result(nptr) ptr_p=ptr ! Find extent of run of free locations - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size do - if(ptr%offset+esize>ptr%data%size+1) then + if(ptr%offset+size>ptr%data%size+1) then exit endif if(marked(ptr)) exit if(gc_xtra_debug) & write(0,*) 'FREE',ptr%offset - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size enddo ptr%data%next_sweep=ptr%offset @@ -746,15 +750,15 @@ function pm_new_small(context,vkind,esize) result(nptr) if(pm_debug_level>3) call pm_verify_heap(context) if(pm_debug_level>0) then - if(mod(nptr%offset-1,esize)/=0& - .or.nptr%offset+esize>nptr%data%size+1) then + if(mod(nptr%offset-1,size)/=0& + .or.nptr%offset+size>nptr%data%size+1) then call pm_panic('misaligned allocation') endif endif ! Always initialise pointers if(vkind>=pm_pointer) & - nptr%data%ptr(nptr%offset:nptr%offset+esize-1)=pm_null_obj + nptr%data%ptr(nptr%offset:nptr%offset+size-1)=pm_null_obj if(gc_xtra_debug) write(0,*) 'all',nptr%offset,nptr%data%next_sweep @@ -763,7 +767,7 @@ function pm_new_small(context,vkind,esize) result(nptr) ! Find next free location in circular chain of blocks subroutine next_free() do - if(ptr%offset+esize>ptr%data%size+1) then + if(ptr%offset+size>ptr%data%size+1) then if(ptr%data%next%tick>=context%tick) then ! Scanned this block before - no hope ok=.false. @@ -781,30 +785,30 @@ subroutine next_free() ptr%data%ptr(ptr%offset)%offset endif if(.not.marked(ptr)) exit - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size enddo end subroutine next_free end function pm_new_small ! Create a new object of >= pm_large_obj_size elements - function pm_new_large(context,vkind,esize) result(ptr) + function pm_new_large(context,vkind,size) result(ptr) type(pm_context),pointer:: context integer(pm_p),intent(in):: vkind - integer(pm_ln):: esize + integer(pm_ln):: size type(pm_ptr):: ptr type(pm_block),pointer:: blk if(pm_debug_level>0) then if(vkindpm_usr) & call pm_panic('New large - bad vkind') - if(esize<=0) & - call pm_panic('New large -ve esize') + if(size<=0) & + call pm_panic('New large -ve size') endif if(context%blocks_allocated>max_blocks) & call pm_gc(context,.false.) - blk=>new_block(context,vkind,esize) + blk=>new_block(context,vkind,size) blk%next=>context%new_large context%new_large=>blk if(pm_debug_level>0) then @@ -813,7 +817,7 @@ function pm_new_large(context,vkind,esize) result(ptr) ptr%data=>blk ptr%offset=1 if(vkind>=pm_pointer) & - ptr%data%ptr(ptr%offset:ptr%offset+esize-1)=pm_null_obj + ptr%data%ptr(ptr%offset:ptr%offset+size-1)=pm_null_obj end function pm_new_large ! Create new string object from FORTRAN string @@ -1548,6 +1552,10 @@ subroutine init_context(context,startup) pm_false_obj%offset=1 pm_true_obj%data%l(pm_true_obj%offset)=.true. pm_false_obj%data%l(pm_false_obj%offset)=.false. + do i=pm_int,pm_num_vkind + pm_empty_obj(i)%data=>new_block(context,int(i,pm_p),0_pm_ln) + pm_empty_obj(i)%offset=0 + enddo endif forall (i=1:pm_large_obj_size, j=pm_int:pm_num_vkind) context%obj_list(i,j)%data=>null() @@ -1658,6 +1666,8 @@ function new_block(context,vkind,esize) result(blk) call pm_panic("Out of memory") endif + if(tsize==0) goto 10 + ! Allocate data area select case(vkind) case(pm_int) @@ -1714,7 +1724,8 @@ function new_block(context,vkind,esize) result(blk) call pm_panic("Out of memory") endif - 10 continue +10 continue + ! Finish initialising block blk%magic=1234567 blk%context=>context diff --git a/src/parser.f90 b/src/parser.f90 index 9e0b75e..caef8b9 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -218,7 +218,7 @@ subroutine dcl_type(parser,def,line) endif if(pm_opts%out_sysmod) write(45,'(I4,A7,A)') line,'type:',trim(def) line=line+1 - if(type_decl(parser)) then + if(typ_decl(parser)) then write(*,*) def call pm_panic('bad intrinsic type') endif @@ -445,6 +445,8 @@ subroutine scan(parser) else sym=sym_pling endif + case('~') + sym=sym_tilde case('/') if(peekchar()=='=') then c=getchar() @@ -557,9 +559,13 @@ subroutine scan(parser) exit endif enddo outer - n=n+1 - buffer(n:n)='"' - val=pm_new_string(parser%context,buffer(1:n)) +!!$ n=n+1 +!!$ buffer(n:n)='"' + if(n==0) then + val=pm_empty_obj(pm_string) + else + val=pm_new_string(parser%context,buffer(1:n)) + endif sym=sym_string parser%lexval=val case('''') @@ -1333,7 +1339,7 @@ recursive function qual(parser,dot_call) result(iserr) logical:: iserr integer:: sym,line,pos iserr=.true. - if(parser%sym==sym_at) then + if(parser%sym==sym_pling) then call scan(parser) call make_node(parser,sym_at,1) endif @@ -1643,12 +1649,32 @@ recursive function term(parser,checkqual) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: checkqual logical:: iserr - integer:: m,name,sym,base,line,pos + integer:: i,m,name,sym,base,line,pos logical:: atstart,dot_call iserr=.true. sym=parser%sym select case(sym) - case(sym_if,sym_switch) + case(sym_if) + call scan(parser) + if(expect(parser,sym_open)) return + if(expr(parser)) return + if(expect(parser,sym_cond)) return + if(expr(parser)) return + if(expect(parser,sym_comma)) return + m=1 + do + if(expr(parser)) return + if(parser%sym/=sym_cond) exit + call scan(parser) + if(expr(parser)) return + m=m+1 + if(expect(parser,sym_comma)) return + enddo + if(expect(parser,sym_close)) return + do i=1,m + call make_node(parser,sym_if_expr,3) + enddo + case(sym_switch) call scan(parser) if(expect(parser,sym_open)) return if(expr(parser)) return @@ -1672,7 +1698,7 @@ recursive function term(parser,checkqual) result(iserr) if(expect(parser,sym_comma)) return enddo if(expect(parser,sym_close)) return - call make_node(parser,merge(sym_if_expr,sym_switch_expr,sym==sym_if),m) + call make_node(parser,sym_switch_expr,m) case(sym_coherent,sym_mirrored,sym_shared) call scan(parser) if(expect(parser,sym_open)) return @@ -1758,7 +1784,8 @@ recursive function term(parser,checkqual) result(iserr) call make_node(parser,sym_type_val,1) case(sym_dash) call scan(parser) - if(parser%sym==sym_number) then + select case(parser%sym) + case(sym_number) if(pm_fast_vkind(parser%lexval)/=pm_long) then call parse_error(parser,& '"''" cannot precede non-default integer constant') @@ -1766,30 +1793,34 @@ recursive function term(parser,checkqual) result(iserr) call push_val(parser,parser%lexval) call scan(parser) call make_node(parser,sym_dash,1) - elseif(parser%sym==sym_true.or.& - parser%sym==sym_false) then + case(sym_string) + call push_val(parser,parser%lexval) + call scan(parser) + call make_node(parser,sym_dash,1) + case(sym_true,sym_false) call push_sym_val(parser,parser%sym) call scan(parser) call make_node(parser,sym_dash,1) - elseif(parser%sym==sym_open) then + case(sym_open) call scan(parser) if(expr(parser)) return if(expect(parser,sym_close)) return call make_node(parser,sym_fix,1) - elseif(parser%sym==sym_open_square) then + case(sym_open_square) call push_sym_val(parser,sym_tuple) if(subscript(parser)) return call simple_call(parser) call make_node(parser,sym_fix,1) - elseif(parser%sym>num_sym) then - call push_sym_val(parser,parser%sym) - call scan(parser) - call make_node(parser,sym_name,1) - call make_node(parser,sym_fix,1) - else - call parse_error(parser,'"''" must be followed by constant value') - return - endif + case default + if(parser%sym>num_sym) then + call push_val(parser,pm_name_val(parser%context,parser%sym)) + call make_node(parser,sym_dash,1) + call scan(parser) + else + call parse_error(parser,'"''" must be followed by constant value') + return + endif + end select case(sym_null) if(parser%sym==sym_open) then call scan(parser) @@ -1966,8 +1997,8 @@ recursive function expr1(parser,priority) result(iserr) if(unary(priority_uminus,sym_plus)) return case(sym_mult) if(unary(priority_uminus,sym_ustar)) return - case(sym_pling) - if(unary(priority_uminus,sym_pling)) return + case(sym_tilde) + if(unary(priority_uminus,sym_tilde)) return case(sym_hash) if(unary(priority_uhash,sym_uhash)) return case(sym_not) @@ -2002,10 +2033,10 @@ recursive function expr1(parser,priority) result(iserr) if(binary(priority_and)) return case(sym_eq,sym_ne) if(binary_none(priority_eq)) return - case(sym_gt,sym_ge,sym_lt,sym_le,sym_in,& - sym_includes,sym_is) + case(sym_gt,sym_ge,sym_lt,sym_le,sym_in,sym_not_in,& + sym_includes,sym_not_includes,sym_is) if(binary_none(priority_gt)) return - case(sym_mod) + case(sym_mod,sym_div) if(binary(priority_mod)) return case(sym_plus,sym_minus) if(binary(priority_add)) return @@ -2096,10 +2127,11 @@ end function expr1 !====================================================== ! Comma separated list of expr !====================================================== - recursive function exprlist(parser,length,nolist) result(iserr) + recursive function exprlist(parser,length,nolist,sym) result(iserr) type(parse_state),intent(inout):: parser integer,intent(out),optional:: length logical,intent(in),optional:: nolist + integer,intent(in),optional:: sym logical:: iserr integer:: n iserr=.true. @@ -2110,8 +2142,13 @@ recursive function exprlist(parser,length,nolist) result(iserr) if(parser%sym/=sym_comma) exit call scan(parser) enddo - if(.not.present(nolist)) & - call make_node(parser,sym_list,n) + if(.not.present(nolist)) then + if(present(sym)) then + call make_node(parser,sym,n) + else + call make_node(parser,sym_list,n) + end if + end if if(present(length)) length=n iserr=.false. end function exprlist @@ -2414,11 +2451,12 @@ end subroutine xexpr !====================================================== ! Extended expression list ( expr, expr... subexpr) !====================================================== - subroutine xexprlist(parser,length) + subroutine xexprlist(parser,length,sym) type(parse_state),intent(inout):: parser integer,intent(out),optional:: length + integer,intent(in),optional:: sym integer:: m - if(exprlist(parser,m)) return + if(exprlist(parser,m,sym=sym)) return if(present(length)) length=m if(subexpr(parser)) return contains @@ -2613,18 +2651,19 @@ recursive function var_stmt(parser,moded_stmt) result(iserr) endif call make_node(parser,sym,n+1) if(ne==n) then - call parse_error(parser,'A "'//trim(sym_names(sym))//'" statement must define at least one object') + call parse_error(parser,& + 'A "'//trim(sym_names(sym))//'" statement must define at least one object') endif if(parser%sym==sym_define) then call scan(parser) if(rhs(parser,n)) return call make_node(parser,sym_define,2) if(subexpr(parser)) return - elseif(present(moded_stmt).or..true.) then + elseif(present(moded_stmt)) then call parse_error(parser,'Must include an initialising expression in a "'//& - sym_names(sym)//' statement') + sym_names(moded_stmt)//' statement') elseif(nu+ne>0) then - call parse_error(parser,'Cannot have "_" or "(...)" in unitialised '//& + call parse_error(parser,'Cannot have "_" in unitialised '//& trim(sym_names(sym))//' declaration') endif iserr=.false. @@ -2677,7 +2716,7 @@ recursive function switch_stmt(parser) result(iserr) n=0 do while(parser%sym==sym_case) call scan(parser) - call xexprlist(parser) + call xexprlist(parser,sym=sym_case) if(expect(parser,sym_colon)) return call stmt_list(parser) n=n+2 @@ -3300,7 +3339,7 @@ function assn_list() result(iserr) iserr=.false. end function assn_list - ! sync name [ qual ] := expr + ! sync name [ qual ] = expr function sync_assign() result(iserr) logical:: iserr iserr=.true. @@ -3746,7 +3785,7 @@ recursive function typunary(parser) result(iserr) elseif(parser%sym==sym_fix) then call scan(parser) if(typunary(parser)) return - call make_node(parser,sym_const,1) + call make_node(parser,sym_fix,1) else if(typval(parser)) return endif @@ -3867,10 +3906,19 @@ recursive function typval(parser) result(iserr) call make_node(parser,sym_pm_dref,m+1) case(sym_dcaret) call scan(parser) - if(expect(parser,sym_open)) return - if(typ(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_dcaret,1) + if(parser%sym==sym_caret) then + call scan(parser) + if(typval(parser)) return + call make_node(parser,sym_const,1) + elseif(parser%sym==sym_dcaret) then + call scan(parser) + call make_node(parser,sym_assign_or_init,0) + else + if(expect(parser,sym_open)) return + if(typ(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_dcaret,1) + endif case(sym_underscore) call scan(parser) call make_node(parser,sym_underscore,0) @@ -4216,7 +4264,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) call scan(parser) if(expect(parser,sym_dotdotdot)) return call push_sym_val(parser,sym_arg) - if(arg_type_with_mode(iscomm)) return + if(arg_typ_with_mode(iscomm)) return call make_node(parser,sym_dotdotdot,m*2+2) exit else if(parser%sym==sym_amp) then @@ -4228,7 +4276,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) endif m=m+1 call push_sym(parser,m) - if(arg_type_with_mode(iscomm)) return + if(arg_typ_with_mode(iscomm)) return else if(parser%sym==sym_key) then call make_node(parser,sym_list,m*2) call push_back(parser,sym_comma) @@ -4249,7 +4297,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) else call parse_error(parser,'Expected argument') endif - if(arg_type_with_mode(iscomm)) return + if(arg_typ_with_mode(iscomm)) return if(parser%sym==sym_define) then parser%temp=pop_val(parser) call drop_val(parser) @@ -4283,7 +4331,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) else if(expect_name(parser, & 'optional argument name')) return - if(arg_type_with_mode(iscomm)) return + if(arg_typ_with_mode(iscomm)) return if(expect(parser,sym_define)) return if(expr(parser)) return n=n+1 @@ -4311,7 +4359,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) return contains - function arg_type_with_mode(iscomm) result(iserr) + function arg_typ_with_mode(iscomm) result(iserr) logical,intent(in):: iscomm logical:: iserr iserr=.true. @@ -4322,7 +4370,7 @@ function arg_type_with_mode(iscomm) result(iserr) call push_null_val(parser) endif iserr=.false. - end function arg_type_with_mode + end function arg_typ_with_mode end function param_list @@ -4421,9 +4469,12 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) case(sym_no_inline) call set_flags(proc_no_inline) call scan(parser) - case(sym_ignore_rules) + case(sym_ignore_rules) call set_flags(call_ignore_rules) call scan(parser) + case(sym_keep_literals) + call set_flags(call_is_fixed) + call scan(parser) end select if(parser%sym/=sym_comma) exit call scan(parser) @@ -4844,7 +4895,7 @@ recursive function proc_sig(parser) result(iserr) call make_node(parser,sym,1) case(sym_pct,sym_define,sym_dot,sym_query,sym_amp,& sym_hash,sym_caret,sym_dcaret,sym_d1:sym_d7,sym_invar,sym_shared,& - sym_type) + sym_type,sym_tilde) ! These return N types based on types of a ! list of N expressions call scan(parser) @@ -4973,7 +5024,7 @@ end subroutine add_proc_decl !====================================================== ! Type declaration !====================================================== - function type_decl(parser) result(iserr) + function typ_decl(parser) result(iserr) type(parse_state):: parser logical:: iserr integer:: sym,m,n,name,basename,namein,base,nextra @@ -4983,7 +5034,7 @@ function type_decl(parser) result(iserr) integer:: sbase,svbase,pname sbase=parser%top svbase=parser%vtop - reg=>pm_register(parser%context,'type_decl',ptr) + reg=>pm_register(parser%context,'typ_decl',ptr) iserr=.true. nextra=0 sym=sym_includes @@ -4998,7 +5049,7 @@ function type_decl(parser) result(iserr) call push_val(parser,parser%modl) ! module ! Type parameters - if(type_params(parser,m)) goto 999 + if(typ_params(parser,m)) goto 999 params=top_val(parser) ! <: typelist @@ -5016,7 +5067,7 @@ function type_decl(parser) result(iserr) call push_val(parser,link) ! [ : typelist ] - if(type_inclusions(parser,name)) goto 999 + if(typ_inclusions(parser,name)) goto 999 ! Body of declaration, either : ! struct or rec @@ -5061,13 +5112,13 @@ function type_decl(parser) result(iserr) call push_null_val(parser) endif 10 continue - call make_node(parser,sym,typ_num_args+nextra) + call make_node(parser,sym,type_num_args+nextra) if(debug_parser_extra) then write(*,*) 'TYPEDECL>----------------' call dump_parse_tree(parser%context,6,top_val(parser),2) write(*,*) 'END TYPEDECL-------------' endif - call add_type_decl(parser,name,ptr) + call add_typ_decl(parser,name,ptr) iserr=.false. 999 continue parser%top=sbase @@ -5077,12 +5128,12 @@ function type_decl(parser) result(iserr) include 'fisnull.inc' - end function type_decl + end function typ_decl !====================================================== ! Parameters to a type declaration !====================================================== - function type_params(parser,m) result(iserr) + function typ_params(parser,m) result(iserr) type(parse_state):: parser integer,intent(out):: m logical:: iserr @@ -5109,13 +5160,13 @@ function type_params(parser,m) result(iserr) call push_null_val(parser) endif iserr=.false. - end function type_params + end function typ_params !====================================================== ! : typelist !====================================================== - function type_inclusions(parser,name) result(iserr) + function typ_inclusions(parser,name) result(iserr) type(parse_state):: parser integer,intent(in):: name logical:: iserr @@ -5130,7 +5181,7 @@ function type_inclusions(parser,name) result(iserr) if(check_name(parser,namein)) then ! An in declaration creates an entry in the ! named parent type - call add_typein_decl(parser,namein,name) + call add_typ_in_decl(parser,namein,name) else call parse_error(parser,'Expecting type name') return @@ -5148,13 +5199,13 @@ function type_inclusions(parser,name) result(iserr) iserr=.false. contains include 'fisnull.inc' - end function type_inclusions + end function typ_inclusions !====================================================== ! Add a declaration that type 'namein' is ! included in type 'name' !====================================================== - subroutine add_typein_decl(parser,namein,name) + subroutine add_typ_in_decl(parser,namein,name) type(parse_state):: parser integer,intent(in):: namein,name type(pm_ptr):: ptrin @@ -5168,15 +5219,15 @@ subroutine add_typein_decl(parser,namein,name) call push_sym_val(parser,name) call make_node(parser,sym_type,1) call make_node(parser,sym_in,2) - call add_type_decl(parser,namein,ptrin) + call add_typ_decl(parser,namein,ptrin) contains include 'fisnull.inc' - end subroutine add_typein_decl + end subroutine add_typ_in_decl !====================================================== ! Add type declaration on top of vstack under name nam !====================================================== - subroutine add_type_decl(parser,nam,p) + subroutine add_typ_decl(parser,nam,p) type(parse_state):: parser integer,intent(in):: nam type(pm_ptr),intent(in):: p @@ -5204,7 +5255,7 @@ subroutine add_type_decl(parser,nam,p) endif contains include 'fisnull.inc' - end subroutine add_type_decl + end subroutine add_typ_decl !====================================================== ! type .. is unique @@ -5453,7 +5504,7 @@ subroutine decl(parser,is_root_module) endif if(proc_decl(parser)) goto 999 case(sym_type) - if(type_decl(parser)) goto 999 + if(typ_decl(parser)) goto 999 case(sym_param) if(param_decl(parser)) goto 999 case(sym_test) diff --git a/src/symbol.f90 b/src/symbol.f90 index e3d9a4c..a848eeb 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -61,14 +61,15 @@ module pm_symbol integer,parameter:: sym_query = 17 integer,parameter:: sym_arrow = 18 integer,parameter:: sym_pct = 19 - integer,parameter:: sym_dash = 20 - integer,parameter:: sym_caret = 21 - integer,parameter:: sym_dcaret = 22 - integer,parameter:: sym_dcolon = 23 - integer,parameter:: sym_define = 24 - integer,parameter:: sym_cond = 25 - integer,parameter:: sym_string = 26 - integer,parameter:: sym_number = 27 + integer,parameter:: sym_pling = 20 + integer,parameter:: sym_dash = 21 + integer,parameter:: sym_caret = 22 + integer,parameter:: sym_dcaret = 23 + integer,parameter:: sym_dcolon = 24 + integer,parameter:: sym_define = 25 + integer,parameter:: sym_cond = 26 + integer,parameter:: sym_string = 27 + integer,parameter:: sym_number = 28 ! Operators integer,parameter:: sym1 = sym_number @@ -97,26 +98,30 @@ module pm_symbol integer,parameter:: sym_bar = sym2 + 12 integer,parameter:: sym_hash= sym2 + 13 integer,parameter:: sym_amp = sym2 + 14 - integer,parameter:: sym_pling = sym2 + 15 + integer,parameter:: sym_tilde = sym2 + 15 ! These keywords and symbols are binary operators - integer,parameter:: first_key = sym_pling + integer,parameter:: first_key = sym_tilde integer,parameter:: sym_in = first_key + 1 - integer,parameter:: sym_and = first_key + 2 - integer,parameter:: sym_or = first_key + 3 - integer,parameter:: sym_xor = first_key + 4 - integer,parameter:: sym_shift = first_key + 5 - integer,parameter:: sym_fmt = first_key + 6 - integer,parameter:: sym_by = first_key + 7 - integer,parameter:: sym_mod = first_key + 8 - integer,parameter:: sym_except = first_key + 9 - integer,parameter:: sym_includes = first_key + 10 - integer,parameter:: sym_ortho = first_key + 11 - integer,parameter:: sym_is = first_key + 12 - integer,parameter:: sym_as = first_key + 13 + integer,parameter:: sym_not_in = first_key + 2 + integer,parameter:: sym_and = first_key + 3 + integer,parameter:: sym_or = first_key + 4 + integer,parameter:: sym_xor = first_key + 5 + integer,parameter:: sym_shift = first_key + 6 + integer,parameter:: sym_fmt = first_key + 7 + integer,parameter:: sym_by = first_key + 8 + integer,parameter:: sym_mod = first_key + 9 + integer,parameter:: sym_div = first_key + 10 + integer,parameter:: sym_except = first_key + 11 + integer,parameter:: sym_includes = first_key + 12 + integer,parameter:: sym_not_includes = first_key + 13 + integer,parameter:: sym_ortho = first_key + 14 + integer,parameter:: sym_is = first_key + 15 + integer,parameter:: sym_is_not = first_key + 16 + integer,parameter:: sym_as = first_key + 17 ! Unary operators - integer,parameter:: sym_not = first_key + 14 + integer,parameter:: sym_not = first_key + 18 integer,parameter:: last_operator = sym_not ! Statement / expression general keywords @@ -138,6 +143,8 @@ module pm_symbol integer,parameter:: last_word = last_expr ! Modes + + integer,parameter:: sym_private = last_word + 1 integer,parameter:: first_mode = sym_private integer,parameter:: sym_invar = last_word + 2 @@ -246,12 +253,13 @@ module pm_symbol integer,parameter:: sym_cond_attr = num_sym + 14 integer,parameter:: sym_uncond = num_sym + 15 integer,parameter:: sym_ignore_rules = num_sym + 16 - + integer,parameter:: sym_keep_literals = num_sym + 17 + ! filesystem - integer,parameter:: sym_filesystem = num_sym + 17 + integer,parameter:: sym_filesystem = num_sym + 18 ! Symbols used as node types (actual name not really used) - integer,parameter:: node0 = num_sym + 17 + integer,parameter:: node0 = num_sym + 18 integer,parameter:: sym_iter = node0 + 1 integer,parameter:: sym_list = node0 + 2 integer,parameter:: sym_builtin = node0 + 3 @@ -298,9 +306,10 @@ module pm_symbol integer,parameter:: sym_get_filesystem = node0 + 44 integer,parameter:: sym_nested_loop = node0 + 45 integer,parameter:: sym_assign_list = node0 + 46 + integer,parameter:: sym_case_range = node0 + 47 ! Misc. other symbols that need to be referenced by the compiler - integer,parameter:: hook = node0 + 47 + integer,parameter:: hook = node0 + 48 integer,parameter:: sym_pval_as = hook integer,parameter:: sym_pm_system = hook+1 integer,parameter:: sym_get_element = hook+2 @@ -363,12 +372,13 @@ module pm_symbol integer,parameter:: sym_node_for = hook2 + 8 integer,parameter:: sym_import_param = hook2 + 9 integer,parameter:: sym_set_elem = hook2 + 10 - integer,parameter:: sym_assign_var = hook2 + 11 - integer,parameter:: sym_vector = hook2 + 12 - integer,parameter:: sym_matrix = hook2 + 13 - integer,parameter:: sym_pdup = hook2 + 14 - integer,parameter:: sym_active = hook2 + 15 - integer,parameter:: hook3 = hook2 + 15 + integer,parameter:: sym_assign_or_init = hook2 + 11 + integer,parameter:: sym_assign_var = hook2 + 12 + integer,parameter:: sym_vector = hook2 + 13 + integer,parameter:: sym_matrix = hook2 + 14 + integer,parameter:: sym_pdup = hook2 + 15 + integer,parameter:: sym_active = hook2 + 16 + integer,parameter:: hook3 = hook2 + 16 integer,parameter:: sym_do_dim = hook3 + 1 integer,parameter:: sym_shape = hook3 + 2 @@ -480,6 +490,7 @@ module pm_symbol data sym_names(sym_query) /'?'/ data sym_names(sym_arrow) /'->'/ data sym_names(sym_pct) /'%'/ + data sym_names(sym_pling) /'!'/ data sym_names(sym_dash) /''''/ data sym_names(sym_caret) /'^'/ data sym_names(sym_dcaret) /'^^'/ @@ -514,9 +525,10 @@ module pm_symbol data sym_names(sym_bar) /'|'/ data sym_names(sym_hash) /'#'/ data sym_names(sym_amp) /'&'/ - data sym_names(sym_pling) /'!'/ + data sym_names(sym_tilde) /'~'/ data sym_names(sym_in) /'in'/ + data sym_names(sym_not_in) /'notin'/ data sym_names(sym_and) /'and'/ data sym_names(sym_or) /'or'/ data sym_names(sym_xor) /'xor'/ @@ -524,10 +536,13 @@ module pm_symbol data sym_names(sym_fmt) /'fmt'/ data sym_names(sym_by) /'by'/ data sym_names(sym_mod) /'mod'/ + data sym_names(sym_div) /'div'/ data sym_names(sym_except) /'except'/ data sym_names(sym_includes) /'inc'/ + data sym_names(sym_not_includes) /'notinc'/ data sym_names(sym_ortho) /'ortho'/ data sym_names(sym_is) /'is'/ + data sym_names(sym_is_not) /'isnt'/ data sym_names(sym_as) /'as'/ data sym_names(sym_not) /'not'/ @@ -642,7 +657,7 @@ module pm_symbol data sym_names(sym_cond_attr) /'cond'/ data sym_names(sym_uncond) /'uncond'/ data sym_names(sym_ignore_rules) /'PM__ignore'/ - + data sym_names(sym_keep_literals) /'keep_literals'/ data sym_names(sym_filesystem) /'filesystem'/ @@ -695,6 +710,7 @@ module pm_symbol data sym_names(sym_get_filesystem) /'PM__filesys'/ data sym_names(sym_nested_loop) /'PM__nested_loop'/ data sym_names(sym_assign_list) /''/ + data sym_names(sym_case_range) /'PM__caserange'/ ! Misc. symbols referenced by compiler @@ -759,6 +775,7 @@ module pm_symbol data sym_names(sym_node_for) /'node_for'/ data sym_names(sym_import_param) /'PM__impparam'/ data sym_names(sym_set_elem) /'PM__setaelem'/ + data sym_names(sym_assign_or_init) /'PM__assign_or_init'/ data sym_names(sym_assign_var) /'PM__assign_var'/ data sym_names(sym_vector) /'vector'/ data sym_names(sym_matrix) /'matrix'/ diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index ffc8743..a289ec9 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -38,30 +38,6 @@ module pm_sysdefs use pm_vmdefs implicit none - ! Flag values for procs - ! (note values 1=proc_is_comm,... defined in parser) - integer,parameter:: proc_is_thru_each = 2**12 - integer,parameter:: proc_is_empty_each = 2**13 - integer,parameter:: proc_is_dup_each = 2**14 - integer,parameter:: proc_is_var = 2**15 - integer,parameter:: proc_is_generator = 2**16 - integer,parameter:: proc_needs_type = 2**17 - integer,parameter:: proc_is_recursive = 2**18 - integer,parameter:: proc_unfinished = 2**19 - integer,parameter:: proc_is_impure = 2**20 - integer,parameter:: proc_is_not_inlinable = 2**21 - integer,parameter:: proc_has_for = 2**22 - integer,parameter:: proc_is_not_pure_each = 2**23 - integer,parameter:: proc_has_vkeys = 2**24 - integer,parameter:: proc_is_dcomm = 2**25 - integer,parameter:: proc_is_file = 2**26 - integer,parameter:: proc_needs_par = 2**27 - integer,parameter:: proc_prints_out = 2**28 - - integer,parameter:: proc_taints = proc_is_impure & - + proc_is_not_inlinable + proc_has_for & - + proc_is_not_pure_each + proc_is_dcomm + proc_is_file & - + proc_needs_par + proc_prints_out contains @@ -73,6 +49,82 @@ subroutine sysdefs(parser) call dcl_module(parser,'PM__system') parser%sysmodl=parser%modl + call dcl_type(parser,'literal is ^^^any',line) + call dcl_type(parser,'int_literal is ^^^int',line) + call dcl_type(parser,'real_literal is ^^^real',line) + call dcl_type(parser,'bool_literal is ^^^bool',line) + call dcl_type(parser,'string_literal is ^^^string',line) + + call dcl_proc(parser,'mod(int_literal,int_literal)->int_literal',op_mod_fold,0,line,0) + call dcl_proc(parser,'==(int_literal,int_literal)->bool_literal',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(int_literal,int_literal)->bool_literal',op_ne_fold,0,line,0) + call dcl_proc(parser,'>=(int_literal,int_literal)->bool_literal',op_ge_fold,0,line,0) + call dcl_proc(parser,'>(int_literal,int_literal)->bool_literal',op_gt_fold,0,line,0) + call dcl_proc(parser,'+(int_literal,int_literal)->int_literal',op_add_fold,0,line,0) + call dcl_proc(parser,'-(int_literal,int_literal)->int_literal',op_sub_fold,0,line,0) + call dcl_proc(parser,'*(int_literal,int_literal)->int_literal',op_mult_fold,0,line,0) + call dcl_proc(parser,'/(int_literal,int_literal)->int_literal',op_divide_fold,0,line,0) + call dcl_proc(parser,'**(int_literal,int_literal)->int_literal',op_pow_fold,0,line,0) + call dcl_proc(parser,'max(int_literal,int_literal)->int_literal',op_max_fold,0,line,0) + call dcl_proc(parser,'min(int_literal,int_literal)->int_literal',op_min_fold,0,line,0) + call dcl_proc(parser,'-(int_literal)->int_literal',op_uminus_fold,0,line,0) + call dcl_proc(parser,'string(int_literal)->string',op_string_fold,0,line,0) + call dcl_proc(parser,'abs(int_literal)->int_literal',op_abs_fold,0,line,0) + call dcl_proc(parser,'~(int_literal)->int_literal',op_bnot_fold,0,line,0) + call dcl_proc(parser,'&(int_literal,int_literal)->int_literal',op_band_fold,0,line,0) + call dcl_proc(parser,'|(int_literal,int_literal)->int_literal',op_bor_fold,0,line,0) + call dcl_proc(parser,'xor(int_literal,int_literal)->int_literal',op_bxor_fold,0,line,0) + call dcl_proc(parser,'shift(int_literal,int_literal)->int_literal',& + op_bshift_fold,0,line,0) + call dcl_proc(parser,'pdiff(int_literal,int_literal)->int_literal',op_pdiff_fold,0,line,0) + call dcl_proc(parser,'sign(int_literal,int_literal)->int_literal',op_sign_fold,0,line,0) + call dcl_proc(parser,'rem(int_literal,int_literal)->int_literal',op_modulo_fold,0,line,0) + call dcl_proc(parser,'and(bool_literal,bool_literal)->bool_literal',op_and_fold,0,line,0) + call dcl_proc(parser,'or(bool_literal,bool_literal)->bool_literal',op_or_fold,0,line,0) + call dcl_proc(parser,'except(bool_literal,bool_literal)->bool_literal',op_except_fold,0,line,0) + call dcl_proc(parser,'==(bool_literal,bool_literal)->bool_literal',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(bool_literal,bool_literal)->bool_literal',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(string_literal,string_literal)->bool_literal',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(string_literal,string_literal)->bool_literal',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(real_literal,real_literal)->bool_literal',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(real_literal,real_literal)->bool_literal',op_ne_fold,0,line,0) + call dcl_proc(parser,'++(string_literal,string_literal)->string_literal',op_concat_fold,0,line,0) + + call dcl_proc(parser,'mod(fix int,fix int)->fix int',op_mod_fold,0,line,0) + call dcl_proc(parser,'==(fix int,fix int)->fix bool',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix int,fix int)->fix bool',op_ne_fold,0,line,0) + call dcl_proc(parser,'>=(fix int,fix int)->fix bool',op_ge_fold,0,line,0) + call dcl_proc(parser,'>(fix int,fix int)->fix bool',op_gt_fold,0,line,0) + call dcl_proc(parser,'+(fix int,fix int)->fix int',op_add_fold,0,line,0) + call dcl_proc(parser,'-(fix int,fix int)->fix int',op_sub_fold,0,line,0) + call dcl_proc(parser,'*(fix int,fix int)->fix int',op_mult_fold,0,line,0) + call dcl_proc(parser,'/(fix int,fix int)->fix int',op_divide_fold,0,line,0) + call dcl_proc(parser,'**(fix int,fix int)->fix int',op_pow_fold,0,line,0) + call dcl_proc(parser,'max(fix int,fix int)->fix int',op_max_fold,0,line,0) + call dcl_proc(parser,'min(fix int,fix int)->fix int',op_min_fold,0,line,0) + call dcl_proc(parser,'-(fix int)->fix int',op_uminus_fold,0,line,0) + call dcl_proc(parser,'string(fix int)->string',op_string_fold,0,line,0) + call dcl_proc(parser,'abs(fix int)->fix int',op_abs_fold,0,line,0) + call dcl_proc(parser,'~(fix int)->fix int',op_bnot_fold,0,line,0) + call dcl_proc(parser,'&(fix int,fix int)->fix int',op_band_fold,0,line,0) + call dcl_proc(parser,'|(fix int,fix int)->fix int',op_bor_fold,0,line,0) + call dcl_proc(parser,'xor(fix int,fix int)->fix int',op_bxor_fold,0,line,0) + call dcl_proc(parser,'shift(fix int,fix int)->fix int',& + op_bshift_fold,0,line,0) + call dcl_proc(parser,'pdiff(fix int,fix int)->fix int',op_pdiff_fold,0,line,0) + call dcl_proc(parser,'sign(fix int,fix int)->fix int',op_sign_fold,0,line,0) + call dcl_proc(parser,'rem(fix int,fix int)->fix int',op_modulo_fold,0,line,0) + call dcl_proc(parser,'and(fix bool,fix bool)->fix bool',op_and_fold,0,line,0) + call dcl_proc(parser,'or(fix bool,fix bool)->fix bool',op_or_fold,0,line,0) + call dcl_proc(parser,'except(fix bool,fix bool)->fix bool',op_except_fold,0,line,0) + call dcl_proc(parser,'==(fix bool,fix bool)->fix bool',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix bool,fix bool)->fix bool',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(fix string,fix string)->fix bool',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix string,fix string)->fix bool',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(fix real,fix real)->fix bool',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix real,fix real)->fix bool',op_ne_fold,0,line,0) + call dcl_proc(parser,'++(fix string,fix string)->fix string',op_concat_fold,0,line,0) + ! ************************************** ! BASIC TYPES ! ************************************** @@ -128,43 +180,43 @@ subroutine sysdefs(parser) ! int type call dcl_proc(parser,'PM__assign_var(&int,int)',& op_assign_ln,0,line,0) - call dcl_proc(parser,'mod(int,int)->''int',op_mod_ln,0,line,0) - call dcl_proc(parser,'==(int,int)->''bool',op_eq_ln,0,line,0) - call dcl_proc(parser,'/=(int,int)->''bool',op_ne_ln,0,line,0) - call dcl_proc(parser,'>=(int,int)->''bool',op_ge_ln,0,line,0) - call dcl_proc(parser,'>(int,int)->''bool',op_gt_ln,0,line,0) - call dcl_proc(parser,'+(int,int)->''int',op_add_ln,0,line,0) - call dcl_uproc(parser,'+(x:int,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int)=y',line) - call dcl_proc(parser,'-(int,int)->''int',op_sub_ln,0,line,0) - call dcl_uproc(parser,'-(x:int,y:''0)=x',line) - call dcl_proc(parser,'*(int,int)->''int',op_mult_ln,0,line,0) + call dcl_proc(parser,'mod(int,int)->int',op_mod_ln,0,line,0) + call dcl_proc(parser,'==(int,int)->bool',op_eq_ln,0,line,0) + call dcl_proc(parser,'/=(int,int)->bool',op_ne_ln,0,line,0) + call dcl_proc(parser,'>=(int,int)->bool',op_ge_ln,0,line,0) + call dcl_proc(parser,'>(int,int)->bool',op_gt_ln,0,line,0) + call dcl_proc(parser,'+(int,int)->int',op_add_ln,0,line,0) +!!$ call dcl_uproc(parser,'+(x:int,y:''0)=x',line) +!!$ call dcl_uproc(parser,'+(x:''0,y:int)=y',line) + call dcl_proc(parser,'-(int,int)->int',op_sub_ln,0,line,0) +!!$ call dcl_uproc(parser,'-(x:int,y:''0)=x',line) + call dcl_proc(parser,'*(int,int)->int',op_mult_ln,0,line,0) call dcl_uproc(parser,'*(x:int,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int)=y',line) - call dcl_proc(parser,'/(int,int)->''int',op_divide_ln,0,line,0) +!!$ call dcl_uproc(parser,'*(x:''1,y:int)=y',line) + call dcl_proc(parser,'/(int,int)->int',op_divide_ln,0,line,0) call dcl_uproc(parser,'/(x:int,y:''1)=x',line) - call dcl_proc(parser,'**(int,int)->''int',op_pow_ln,0,line,0) - call dcl_uproc(parser,'**(x:int,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) - call dcl_proc(parser,'max(int,int)->''int',op_max_ln,0,line,0) - call dcl_proc(parser,'min(int,int)->''int',op_min_ln,0,line,0) - call dcl_proc(parser,'-(int)->''int',op_uminus_ln,0,line,0) + call dcl_proc(parser,'**(int,int)->int',op_pow_ln,0,line,0) +!!$ call dcl_uproc(parser,'**(x:int,y:''0)=1',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''1)=x',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) + call dcl_proc(parser,'max(int,int)->int',op_max_ln,0,line,0) + call dcl_proc(parser,'min(int,int)->int',op_min_ln,0,line,0) + call dcl_proc(parser,'-(int)->int',op_uminus_ln,0,line,0) call dcl_proc(parser,'string(int)->string',op_string_ln,0,line,0) call dcl_proc(parser,'sint(int)->sint',op_int_ln,0,line,0) call dcl_proc(parser,'sreal(int)->sreal',op_real_ln,0,line,0) call dcl_proc(parser,'real(int)->real',op_double_ln,0,line,0) call dcl_uproc(parser,'int(x:int)=x',line) call dcl_proc(parser,'abs(int)->int',op_abs_ln,0,line,0) - call dcl_proc(parser,'!(int)->int',op_bnot_ln,0,line,0) + call dcl_proc(parser,'~(int)->int',op_bnot_ln,0,line,0) call dcl_proc(parser,'&(int,int)->int',op_band_ln,0,line,0) call dcl_proc(parser,'|(int,int)->int',op_bor_ln,0,line,0) call dcl_proc(parser,'xor(int,int)->int',op_bxor_ln,0,line,0) call dcl_proc(parser,'shift(int,int)->int',& op_bshift_ln,0,line,0) - call dcl_proc(parser,'pdiff(int,int)->''int',op_pdiff_ln,0,line,0) - call dcl_proc(parser,'sign(int,int)->''int',op_sign_ln,0,line,0) - call dcl_proc(parser,'rem(int,int)->''int',op_modulo_ln,0,line,0) + call dcl_proc(parser,'pdiff(int,int)->int',op_pdiff_ln,0,line,0) + call dcl_proc(parser,'sign(int,int)->int',op_sign_ln,0,line,0) + call dcl_proc(parser,'rem(int,int)->int',op_modulo_ln,0,line,0) call dcl_proc(parser,'int8(int)->int8',op_i8_ln,0,line,0) call dcl_proc(parser,'int16(int)->int16',op_i16_ln,0,line,0) call dcl_proc(parser,'int32(int)->int32',op_i32_ln,0,line,0) @@ -202,7 +254,7 @@ subroutine sysdefs(parser) call dcl_proc(parser,'real(lint)->real',op_double_offset,0,line,0) call dcl_uproc(parser,'lint(x:lint)=x',line) call dcl_proc(parser,'abs(lint)->lint',op_abs_offset,0,line,0) - call dcl_proc(parser,'!(lint)->lint',op_bnot_offset,0,line,0) + call dcl_proc(parser,'~(lint)->lint',op_bnot_offset,0,line,0) call dcl_proc(parser,'&(lint,lint)->lint',op_band_offset,0,line,0) call dcl_proc(parser,'|(lint,lint)->lint',op_bor_offset,0,line,0) call dcl_proc(parser,'xor(lint,lint)->lint',op_bxor_offset,0,line,0) @@ -247,7 +299,7 @@ subroutine sysdefs(parser) call dcl_proc(parser,'real(int8)->real',op_double_i8,0,line,0) call dcl_uproc(parser,'int8(x:int8)=x',line) call dcl_proc(parser,'abs(int8)->int8',op_abs_i8,0,line,0) - call dcl_proc(parser,'!(int8)->int8',op_bnot_i8,0,line,0) + call dcl_proc(parser,'~(int8)->int8',op_bnot_i8,0,line,0) call dcl_proc(parser,'&(int8,int8)->int8',op_band_i8,0,line,0) call dcl_proc(parser,'|(int8,int8)->int8',op_bor_i8,0,line,0) call dcl_proc(parser,'xor(int8,int8)->int8',op_bxor_i8,0,line,0) @@ -292,7 +344,7 @@ subroutine sysdefs(parser) call dcl_proc(parser,'real(int16)->real',op_double_i16,0,line,0) call dcl_uproc(parser,'int16(x:int16)=x',line) call dcl_proc(parser,'abs(int16)->int16',op_abs_i16,0,line,0) - call dcl_proc(parser,'!(int16)->int16',op_bnot_i16,0,line,0) + call dcl_proc(parser,'~(int16)->int16',op_bnot_i16,0,line,0) call dcl_proc(parser,'&(int16,int16)->int16',op_band_i16,0,line,0) call dcl_proc(parser,'|(int16,int16)->int16',op_bor_i16,0,line,0) call dcl_proc(parser,'xor(int16,int16)->int16',op_bxor_i16,0,line,0) @@ -337,7 +389,7 @@ subroutine sysdefs(parser) call dcl_proc(parser,'real(int32)->real',op_double_i32,0,line,0) call dcl_uproc(parser,'int32(x:int32)=x',line) call dcl_proc(parser,'abs(int32)->int32',op_abs_i32,0,line,0) - call dcl_proc(parser,'!(int32)->int32',op_bnot_i32,0,line,0) + call dcl_proc(parser,'~(int32)->int32',op_bnot_i32,0,line,0) call dcl_proc(parser,'&(int32,int32)->int32',op_band_i32,0,line,0) call dcl_proc(parser,'|(int32,int32)->int32',op_bor_i32,0,line,0) call dcl_proc(parser,'xor(int32,int32)->int32',op_bxor_i32,0,line,0) @@ -383,7 +435,7 @@ subroutine sysdefs(parser) call dcl_proc(parser,'real(int64)->real',op_double_i64,0,line,0) call dcl_uproc(parser,'int64(x:int64)=x',line) call dcl_proc(parser,'abs(int64)->int64',op_abs_i64,0,line,0) - call dcl_proc(parser,'!(int64)->int64',op_bnot_i64,0,line,0) + call dcl_proc(parser,'~(int64)->int64',op_bnot_i64,0,line,0) call dcl_proc(parser,'&(int64,int64)->int64',op_band_i64,0,line,0) call dcl_proc(parser,'|(int64,int64)->int64',op_bor_i64,0,line,0) call dcl_proc(parser,'xor(int64,int64)->int64',op_bxor_i64,0,line,0) @@ -659,6 +711,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'balance(x:_to_scpx,y:scpx)=scpx(x),y',line) call dcl_uproc(parser,'balance(x:_to_cpx,y:cpx)=cpx(x),y',line) + call dcl_uproc(parser,& + 'div(x:any_int,y:any_int)=if(sz=>r,-1-r)'//& + 'where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))'//& + 'where sz=sign(x,y)==x',line) + call dcl_uproc(parser,& + '_divz(x:any_int,y:any_int)=z '//& + '{var z,_=balance(x,y);if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y)}',line) call dcl_uproc(parser,& 'mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& @@ -679,6 +738,14 @@ subroutine sysdefs(parser) '/(x:num,y:num)=xx/yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& '**(x:num,y:num)=xx**yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '&(x:num,y:num)=xx&yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '|(x:num,y:num)=xx|yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& 'max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& @@ -694,37 +761,37 @@ subroutine sysdefs(parser) call dcl_proc(parser,'==(bool,bool)->bool',op_eq_l,0,line,0) call dcl_proc(parser,'/=(bool,bool)->bool',op_ne_l,0,line,0) - ! Compile time bool values - call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) - call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) - call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'not(x:''true)=''false',line) - call dcl_uproc(parser,'not(x:''false)=''true',line) - call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) - call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) - call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) +!!$ ! Compile time bool values +!!$ call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'not(x:''true)=''false',line) +!!$ call dcl_uproc(parser,'not(x:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) ! Masked types call dcl_type(parser,'masked(x) is '//& @@ -844,13 +911,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'indices(x:tuple6d)=[''1,''2,''3,''4,''5,''6]',line) call dcl_uproc(parser,'indices(x:tuple7d)=[''1,''2,''3,''4,''5,''6,''7]',line) - call dcl_uproc(parser,'full_rank(x:tuple1d)=''1',line) - call dcl_uproc(parser,'full_rank(x:tuple2d)=''2',line) - call dcl_uproc(parser,'full_rank(x:tuple3d)=''3',line) - call dcl_uproc(parser,'full_rank(x:tuple4d)=''4',line) - call dcl_uproc(parser,'full_rank(x:tuple5d)=''5',line) - call dcl_uproc(parser,'full_rank(x:tuple6d)=''6',line) - call dcl_uproc(parser,'full_rank(x:tuple7d)=''7',line) + call dcl_uproc(parser,'full_rank(x:tuple1d)=1',line) + call dcl_uproc(parser,'full_rank(x:tuple2d)=2',line) + call dcl_uproc(parser,'full_rank(x:tuple3d)=3',line) + call dcl_uproc(parser,'full_rank(x:tuple4d)=4',line) + call dcl_uproc(parser,'full_rank(x:tuple5d)=5',line) + call dcl_uproc(parser,'full_rank(x:tuple6d)=6',line) + call dcl_uproc(parser,'full_rank(x:tuple7d)=7',line) call dcl_uproc(parser,'rank(x:tuple)=full_rank(x)',line) @@ -1267,6 +1334,12 @@ subroutine sysdefs(parser) ! RANGES AND SEQUENCES ! ***************************************************** + ! Not in operator + call dcl_uproc(parser,'notin(x,y)=not(x in y)',line) + + ! not inc operator + call dcl_uproc(parser,'notinc(x,y)=not(x inc y)',line) + ! Treat null as empty sequence in some cases call dcl_uproc(parser,'in(x,y:null)=''false',line) call dcl_uproc(parser,'in(x:null,y:null)=''true',line) @@ -1321,8 +1394,8 @@ subroutine sysdefs(parser) call dcl_type(parser,'range(t:range_base) is rec {_lo:t,_hi:t,_n:t}',line) call dcl_uproc(parser,'..(x:range_base,y:range_base)='//& 'new range {_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& - 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) +!!$ call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& +!!$ 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) call dcl_uproc(parser,'low(x:range)=x._lo',line) call dcl_uproc(parser,'high(x:range)=x._hi',line) call dcl_uproc(parser,'step(x:range)=convert(1,x._lo)',line) @@ -1756,10 +1829,10 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_act(x,y)=y',line) call dcl_uproc(parser,'active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y)',line) call dcl_uproc(parser,'active_dims(x:single_point,y)=null',line) - call dcl_uproc(parser,'_ar(x:single_point)=''0',line) - call dcl_uproc(parser,'_ar(x)=''1',line) + call dcl_uproc(parser,'_ar(x:single_point)=0',line) + call dcl_uproc(parser,'_ar(x)=1',line) call dcl_uproc(parser,'rank(x:iterable_grid)=map_reduce($_ar,$+,x)',line) - call dcl_uproc(parser,'element(x:iterable_grid,y:index)'//& + call dcl_uproc(parser,'element(x:iterable_grid,y:index)'//& '{t=_tup(y);return _ges(head(x),tail(x),head(t),tail(t),''false)}',line) call dcl_uproc(parser,'element(x:grid_slice,arg...:grid_slice)'//& '{t=_tup(arg...);'//& @@ -2462,10 +2535,10 @@ subroutine sysdefs(parser) op_array,0,line,proc_needs_type) call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->PM__vdim x,y',& op_var_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& - op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& - merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& +!!$ op_array,0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& +!!$ merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) call dcl_proc(parser,& '_redim(x:any^any,y:any)->over x,y',& op_redim,0,line,proc_needs_type) @@ -2593,25 +2666,16 @@ subroutine sysdefs(parser) ! ***************************************** ! Array templates - call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool,i:fix bool,f:fix bool)'//& - ' is rec {_a:a,_d:d,_s:int,_v:v,_i:i=''false,_f:f=''false}',line) + call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool)'//& + ' is rec {_a:a,_d:d,_s:int,_v:v}',line) call dcl_uproc(parser,& 'array(a:any,s:dshape)='//& 'new array_template {_a=a,_d=s,_s=s._size,_v=''false}',line) call dcl_uproc(parser,& 'array(a:any,s:mshape(tuple(range(int))))='//& 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) - call dcl_uproc(parser,& - 'array(a:any,s:fix mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_f=''true}',line) call dcl_uproc(parser,& 'array(a:any,s:tuple(range(any_int)))=array(a,shape(s))',line) - call dcl_uproc(parser,'dim%(a,d)=array(a,d)',line) - call dcl_uproc(parser,'dim%(a,s:invar mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}',line) - call dcl_uproc(parser,'dim%(a,sh:invar tuple(range(any_int)))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}'//& - 'where s=shape(sh)',line) call dcl_uproc(parser,& 'varray(a:any,s:mshape or dshape)='//& @@ -2636,10 +2700,8 @@ subroutine sysdefs(parser) ! Array creation from template call dcl_uproc(parser,'PM__dup(a:array_template(,shape,))='//& '_array(PM__dup(a._a),a._d,int(a._s),a._v)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,,''true))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''false)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,''true,''false))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''true)',line) + call dcl_uproc(parser,'PM__dup(a:array_template(,shape,''true))='//& + '_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v)',line) call dcl_uproc(parser,'PM__do_dim(a:any,d:mshape)='//& '_array(a,d,size(d),''false)',& @@ -3398,7 +3460,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) call dcl_uproc(parser,'_capn%(x,h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) - ! Treat @ variables differently only for limited circumstances in drefs + ! Treat ! variables differently only for limited circumstances in drefs call dcl_uproc(parser,'_drat(at,tile,t)=''false',line) call dcl_uproc(parser,'_drat(at:''true,tile:tuple(range or block_seq),t:indexed and _dr)=''true',line) call dcl_type(parser,'_di(n) is indexed_dim(''1,''1,,n) or int',line) @@ -3421,18 +3483,18 @@ subroutine sysdefs(parser) ' p=index(dims(region.dist),node);'//& ' _send_slice(p,a,region.dist[node])}}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> {'//& - 'chan var xx=_v1%(x);_getref_s%(&xx@,^^(x),at);_bcast_shared(&xx);return xx}',line) + 'chan var xx=_v1%(x);_getref_s%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_irecv(_v4(x),&xx)};'//& '_scatter(x,region);'//& '_sync_messages(xx,x)}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{'//& - 'chan var xx=_v1%(x);_getref_sc%(&xx@,^^(x),at);_bcast_shared(&xx);return xx}',line) + 'chan var xx=_v1%(x);_getref_sc%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) PM__node {'//& '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& '_sync_messages(xx,x)}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> {'//& - 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a@))),'//& + 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a!))),'//& '^^(x),at <>);'//& '_bcast_shared(&a);return a}',line) call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) PM__node {'//& @@ -3442,7 +3504,7 @@ subroutine sysdefs(parser) '}',line) call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> {'//& 'chan var a=_arb(_v2%(x));'//& - '_getref_dc%(&a@,^^(x),at <>);_bcast_shared(&a);return a}',line) + '_getref_dc%(&a!,^^(x),at <>);_bcast_shared(&a);return a}',line) call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& '_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) '//& @@ -4450,7 +4512,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'nbr%(x:chan,t:shared disp_index,v:shared){'//& ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& ' j=displace(region._mshape,here,t);'//& - ' var y=v;if contains(region._mshape,j) {y=x@[j]};'//& + ' var y=v;if contains(region._mshape,j) {y=x![j]};'//& ' return y} ',line) call dcl_uproc(parser,& 'nbhd%(x:chan,t:shared disp_sub,v:shared) { '//& @@ -4458,7 +4520,7 @@ subroutine sysdefs(parser) ' var a=array(v,#t);'//& ' foreach invar i in t {'//& ' j=displace(region._mshape,here,i);'//& - ' if j in region._mshape {a[here]=x@[j]}'//& + ' if j in region._mshape {a[here]=x![j]}'//& ' };return a}',line) ! *** Blocked distributions *** @@ -4985,16 +5047,16 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__get_tilesz(d)=d._tile,d._size',line) call dcl_uproc(parser,'PM__get_tilesz(d:mshape)=d,size(d)',line) - ! Support for @ operator + ! Support for ! operator if(pm_is_compiling) then call dcl_uproc(parser,& 'PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region))',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region,size(region))'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) call dcl_uproc(parser,& 'PM__makearray%(x:invar)=_makearray(x,region,size(region))'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& '_makearray(x:any,y:any,z:any)->PM__invar_dim x,y',& op_make_array,0,line,proc_needs_type) @@ -5003,10 +5065,10 @@ subroutine sysdefs(parser) 'PM__makearray%(x:chan) complete <>=_makearray(x,region)',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region)'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) call dcl_uproc(parser,& 'PM__makearray%(x:invar)=_makearray(x,region)'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& '_makearray(x:any,y:any)->PM__dim x,y',& op_make_array,0,line,proc_needs_type) @@ -5082,7 +5144,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) call dcl_uproc(parser,'PM__do_over%(x:invar grid) complete <>'//& '{chan var t=false;'//& - ' _in%(x,&^(PM__local(^(&t@))) <>);'//& + ' _in%(x,&^(PM__local(^(&t!))) <>);'//& ' return t}',line) call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) call dcl_uproc(parser,'_in%(x:invar,&t:invar) shared <>{forall i in x {sync t[i]=true}}',line) @@ -5260,6 +5322,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'file is struct {_f:sint,_tag:PM__distr_tag}',line) call dcl_type(parser,'io_error is rec {_errno:sint,use _iserr:bool}',line) call dcl_uproc(parser,'PM__filesys()=new filesystem{}',line) + ! call dcl_uproc(parser,'PM__filesys()=0',line) ! Basic operations call dcl_uproc(parser,'open(&filesystem:filesystem,name,'//& @@ -5627,9 +5690,9 @@ subroutine sysdefs(parser) 'chan yy=y;return init / _reduce%($*,yy,init)}',line) call dcl_uproc(parser,'reduce%(p:invar proc,y:chan,init)='//& - '^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y@) <>)<>)),uniform)',line) + '^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform)',line) call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& - '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y@) <>)<>),uniform)',line) + '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform)',line) call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y)',line) call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y)',line) @@ -5654,40 +5717,87 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__getkey(x:any,y:any)=convert(x,y)',line) call dcl_uproc(parser,'PM__getkey(x:null,y:any)=y',line) - ! Select statement - call dcl_uproc(parser,& - 'PM__checkcase(x,y,arg...) { var e=match_switch_case(x,y); '//& - 'if not e { e=PM__checkcase(x,arg...) };return e }',line) + ! Switch statement + call dcl_uproc(parser,'PM__checkcase(x:literal,y:literal)=match_switch_case(x,y)',line) call dcl_uproc(parser,'PM__checkcase(x,y)=match_switch_case(x,y)',line) + call dcl_uproc(parser,'match_switch_case(x:literal,y:literal)=x==y',line) + call dcl_uproc(parser,'match_switch_case(x:fix any,y:fix any)=x==y',line) call dcl_uproc(parser,'match_switch_case(x,y)=x==y',line) call dcl_uproc(parser,& 'match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi',& line) + call dcl_uproc(parser,& + 'match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:int_literal,y:_crange)=(x>=y._lo and x<=y._hi) as ',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi',& + line) call dcl_uproc(parser,'match_switch_case(x:,y:)=y inc x',line) + call dcl_type(parser,'_crange is rec{_lo,_hi}',line) + call dcl_uproc(parser,'PM__caserange(x,y)=x..y',line) + call dcl_uproc(parser,'PM__caserange(x:fix(int),y:fix(int))='//& + 'new _crange{_lo=x,_hi=y}',line) ! Conditional operators call dcl_uproc(parser,& - 'PM__if(x,y,z) check "Incompatible types in different ""if""branches"=> '//& + 'PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> '//& 'same_type(y,z) { var r=z; if x { r=y };return r }',& line) +!!$ call dcl_uproc(parser,'PM__if(x:bool_literal,y,z)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=> '//& +!!$ 'same_type(y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:int_literal,z:int_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:real_literal,z:real_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:string_literal,z:string_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:bool_literal,z:bool_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:literal,z:literal)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=>''false',line) + +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z)=PM__do_if(x,y,z)',line) + call dcl_uproc(parser,'PM__if(x:''true,y,z)=y',line) call dcl_uproc(parser,'PM__if(x:''false,y,z)=z',line) - call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) + call dcl_uproc(parser,'PM__if(x:''true,y:literal,z)=y',line) + call dcl_uproc(parser,'PM__if(x:''false,y,z:literal)=z',line) +!!$ call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) call dcl_uproc(parser,& 'PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> '//& 'same_type(y,z) { var r=z; if match(w,x) { r=y };return r }',& line) + call dcl_uproc(parser,'PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z)',line) + + call dcl_uproc(parser,'PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...))',line) ! Assignment - call dcl_uproc(parser,'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) + call dcl_uproc(parser,& + 'PM__assign_or_init(a,b)<>=a {PM__assign_var(&^(a),b)}',line) + call dcl_uproc(parser,& + 'PM__assign_or_init(a:,b)=PM__dup(b as a)',line) + call dcl_uproc(parser,& + 'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) call dcl_uproc(parser,& 'PM__assign(&a:any,b:any) {check_assign_types(a,b);_assign(&a,b)}',line) - call dcl_type(parser,'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) + call dcl_type(parser,& + 'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) call dcl_uproc(parser,& 'PM__assign(&a:any,b:any,c:assignment_operator) { PM__assign(&a,c.(a,b)) }',line) call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any,c:proc) { test "Not a recognised assignment operator"=>''false }',line) + 'PM__assign(&a:any,b:any,c:proc) { '//& + 'test "Not a recognised assignment operator"=>''false }',line) call dcl_uproc(parser,'check_assign_types(x,y)'//& '{test "Type mismatch in assignment"=>same_type(x,y)}',line) call dcl_uproc(parser,'_assign(&a,b) {_assign_element(&a,b)}',line) @@ -5699,6 +5809,11 @@ subroutine sysdefs(parser) ! Other variable operations call dcl_proc(parser,'PM__clone(x:any)->=x',op_clone,0,line,0) call dcl_uproc(parser,'PM__dup(PM__dup) <>=PM__clone(PM__dup)',line) + call dcl_proc(parser,'PM__dup(x:fix int)->int',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix real)->real',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix string)->string',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix bool)->bool',op_clone,0,line,0) + call dcl_proc(parser,'PM__getref(x:any)->=x',op_get_rf,0,line,0) call dcl_proc(parser,'same_type(x:any,y:any)->==x,y',& op_logical_return,0,line,proc_needs_type) @@ -5719,6 +5834,7 @@ subroutine sysdefs(parser) ! Type values call dcl_proc(parser,'typeof(x:any)->type x',op_make_type_val,0,line,proc_needs_type) call dcl_uproc(parser,'is(x,t)=t inc typeof(x)',line) + call dcl_uproc(parser,'isnt(x,t)=not(x is t)',line) call dcl_uproc(parser,'as(x,t:)...=PM__cast(x,t)',line) call dcl_uproc(parser,'as(x,t)=PM__cast(x,typeof(t))',line) call dcl_proc(parser,'inc(x:,y:)-> inc x,y',op_logical_return,0,line,proc_needs_type) diff --git a/src/types.f90 b/src/types.f90 index 24628b5..c12e04d 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -67,12 +67,12 @@ module pm_types pm_type_has_storage integer,parameter:: pm_type_new_value=12 integer,parameter:: pm_type_new_contains=13 - integer,parameter:: pm_type_new_const=14+pm_type_has_storage + integer,parameter:: pm_type_new_fix=14 !+pm_type_has_storage integer,parameter:: pm_type_new_dref=15 integer,parameter:: pm_type_new_par_kind=16 integer,parameter:: pm_type_new_proc_sig=17 integer,parameter:: pm_type_new_undef_result=18 - !integer,parameter:: pm_type_new_interface=19 + integer,parameter:: pm_type_new_literal=19 integer,parameter:: pm_type_new_except=20 integer,parameter:: pm_type_new_param=21+pm_type_has_params integer,parameter:: pm_type_new_amp=22 @@ -83,6 +83,8 @@ module pm_types integer,parameter:: pm_type_new_enveloped=27 integer,parameter:: pm_type_new_bottom=28 integer,parameter:: pm_type_new_includes=29 + integer,parameter:: pm_type_new_unfixed=30 + integer,parameter:: pm_type_new_uninitialised=31 ! Type kinds integer,parameter:: pm_type_is_basic=0 @@ -99,12 +101,12 @@ module pm_types integer,parameter:: pm_type_is_poly=11 integer,parameter:: pm_type_is_value=12 integer,parameter:: pm_type_is_contains=13 - integer,parameter:: pm_type_is_const=14 + integer,parameter:: pm_type_is_fix=14 integer,parameter:: pm_type_is_dref=15 integer,parameter:: pm_type_is_par_kind=16 integer,parameter:: pm_type_is_proc_sig=17 integer,parameter:: pm_type_is_undef_result=18 - !integer,parameter:: pm_type_is_interface=19 + integer,parameter:: pm_type_is_literal=19 integer,parameter:: pm_type_is_except=20 integer,parameter:: pm_type_is_param=21 integer,parameter:: pm_type_is_amp=22 @@ -115,6 +117,8 @@ module pm_types integer,parameter:: pm_type_is_enveloped=27 integer,parameter:: pm_type_is_bottom=28 integer,parameter:: pm_type_is_includes=29 + integer,parameter:: pm_type_is_unfixed=30 + integer,parameter:: pm_type_is_uninitialised=31 integer,parameter:: pm_type_kind_mask=31 integer,parameter:: pm_type_max_leaves=255 @@ -481,18 +485,41 @@ end function pm_new_includes_type !========================================== ! Create new compile time value type !========================================== - function pm_new_value_type(context,val) result(tno) + function pm_new_fix_type(context,val,vindex) result(tno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val + integer,intent(in),optional:: vindex integer:: tno integer,dimension(3):: args args(1)=pm_type_new_value + if(present(vindex)) then + args(2)=vindex + else + args(2)=pm_set_add(context,context%vcache,val) + endif + args(3)=pm_fast_typeof(val) + if(args(3)==pm_string) args(3)=pm_string_type + tno=pm_new_basic_type(context,args,val) + contains + include 'ftypeof.inc' + end function pm_new_fix_type + + !========================================== + ! Create new compile time value type + !========================================== + function pm_new_literal_type(context,val) result(tno) + type(pm_context),pointer:: context + type(pm_ptr),intent(in):: val + integer:: tno + integer,dimension(3):: args + args(1)=pm_type_new_literal args(2)=pm_set_add(context,context%vcache,val) args(3)=pm_fast_typeof(val) + if(args(3)==pm_string) args(3)=pm_string_type tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' - end function pm_new_value_type + end function pm_new_literal_type !============================================== ! Create new compile time name value type @@ -768,7 +795,6 @@ end function pm_type_val !=============================================== ! Strip off non-storage elements of a type - ! including one-element structs/recs !=============================================== recursive function pm_type_strip_to_basic(context,typ) result(typ2) type(pm_context),pointer:: context @@ -779,7 +805,9 @@ recursive function pm_type_strip_to_basic(context,typ) result(typ2) tv=pm_type_vect(context,typ) kind=pm_tv_kind(tv) select case(kind) - case(pm_type_is_all,pm_type_is_vect,pm_type_is_enveloped,pm_type_is_param) + case(pm_type_is_all,pm_type_is_vect,pm_type_is_enveloped,& + pm_type_is_param,& + pm_type_is_value,pm_type_is_literal) typ2=pm_type_strip_to_basic(context,pm_tv_arg(tv,1)) case(pm_type_is_user) typ2=pm_user_type_body(context,typ) @@ -1270,7 +1298,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& endif case(pm_type_is_value) select case(tk) - case(pm_type_is_const) + case(pm_type_is_fix) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& params,base,user,ubase) return @@ -1282,10 +1310,25 @@ recursive function pm_test_type_includes(context,supertype,subtype,& params,base,user,ubase) return end select - case(pm_type_is_const) - ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,einfo,& - params,base,user,ubase) - return + case(pm_type_is_literal) + if(tk==pm_type_is_unfixed) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + params,base,user,ubase) + return + elseif(tk==pm_type_is_literal) then + ok=pm_tv_name(t)==pm_tv_name(u) + return + end if + case(pm_type_is_fix,pm_type_is_unfixed) + if(tk==uk.or.tk==pm_type_is_fix) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + params,base,user,ubase) + return + elseif(tk/=pm_type_is_user) then + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,einfo,& + params,base,user,ubase) + return + endif case(pm_type_is_user) if(tk/=pm_type_is_user) then do i=2,ubase,2 @@ -1381,7 +1424,8 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=.true. return end select - + + ! Now do tests that look at 1st type first select case(tk) case(pm_type_is_basic) ok=.false. @@ -1652,20 +1696,16 @@ recursive function pm_test_type_includes(context,supertype,subtype,& mode,einfo,params,base,user,ubase) endif endif - case(pm_type_is_value) - if(uk/=pm_type_is_value) then - ok=.false. - else - ok=pm_tv_name(t)==pm_tv_name(u) - endif - case(pm_type_is_const) - if(uk/=pm_type_is_const.and.uk/=pm_type_is_value) then - ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - if(iand(pm_type_flags(context,q),pm_type_has_storage)/=0) ok=.false. + case(pm_type_is_value,pm_type_is_literal) + ok=.false. + case(pm_type_is_fix) + ok=.false. + case(pm_type_is_unfixed) + if(tk==uk) then + ok=pm_tv_arg(t,1)==0.or.& + pm_tv_arg(t,1)==pm_tv_arg(u,1) else - ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + ok=.false. endif case(pm_type_is_enveloped) if(uk==pm_type_is_enveloped) then @@ -1700,7 +1740,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& params(nt)=pm_type_combine(context,params(nt),q) endif endif - case(pm_type_is_amp,pm_type_is_vect) + case(pm_type_is_amp,pm_type_is_vect,pm_type_is_uninitialised) ok=tk==uk if(ok) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) @@ -1869,16 +1909,20 @@ end function pm_type_contains_elem ! Perform enveloping conversions if possible ! Returns -1 if not possible !============================================== - function pm_type_convert(context,partyp,argtyp,dopoly) result(ctyp) + function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp - logical,intent(in):: dopoly + logical,intent(in):: doliteral,doproc,dopoly integer:: ctyp integer:: tk,ptyp type(pm_ptr):: tv + type(pm_type_einfo):: einfo + integer:: arr(3) +!!$ write(*,*) 'Convert',trim(pm_type_as_string(context,partyp)),& +!!$ '<-',trim(pm_type_as_string(context,argtyp)),doliteral ctyp=-1 ptyp=partyp - if(partyp<=0.or.argtyp<=0) then + if(partyp<0.or.argtyp<0) then return endif tk=pm_type_kind(context,ptyp) @@ -1886,7 +1930,23 @@ function pm_type_convert(context,partyp,argtyp,dopoly) result(ctyp) ptyp=pm_user_type_body(context,ptyp) tk=pm_type_kind(context,ptyp) enddo - if(ctyp<0.and.tk==pm_type_is_proc) then + if(doliteral.and.pm_type_kind(context,argtyp)==pm_type_is_literal) then + ctyp=pm_type_arg(context,argtyp,1) + if(tk==pm_type_is_fix) then + if(pm_type_includes(context,pm_type_arg(context,ptyp,1),ctyp,& + pm_type_incl_val,einfo)) then + ctyp=pm_new_fix_type(context,& + pm_type_val(context,argtyp),pm_type_name(context,argtyp)) + endif + elseif(tk==pm_type_is_value) then + if(pm_type_name(context,ptyp)==pm_type_name(context,argtyp)) then + ctyp=ptyp + endif + elseif(tk==pm_type_is_unfixed) then + ctyp=argtyp + endif + endif + if(ctyp<0.and.doproc.and.tk==pm_type_is_proc) then ctyp=pm_proc_type_convert(context,ptyp,argtyp) endif if(ctyp<0.and.dopoly.and.tk==pm_type_is_poly) then @@ -1916,8 +1976,6 @@ function pm_poly_type_convert(context,partyp,argtyp) result(ctyp) end function pm_poly_type_convert - - !========================================== ! Autoconversion to proc signature type ! Returns -1 if not possible @@ -2396,7 +2454,7 @@ recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result tk=pm_tv_kind(tv) select case(tk) case(pm_type_is_basic,pm_type_is_single_name,& - pm_type_is_proc,pm_type_is_value,pm_type_is_const,& + pm_type_is_proc,pm_type_is_value,pm_type_is_fix,& pm_type_is_undef_result,pm_type_is_poly) tno2=tno case(pm_type_is_user) @@ -2787,8 +2845,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) case(pm_type_is_poly) if(add_char('*')) return call bracket(1,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) - case(pm_type_is_value) - if(add_char('''')) return + case(pm_type_is_value,pm_type_is_literal) + if(tk==pm_type_is_value) then + if(add_char('''')) return + endif if(pm_tv_name(tv)==0) then call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) else @@ -2799,15 +2859,28 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) else if(add_char('false')) return endif + elseif(pm_fast_vkind(nv)==pm_string) then + str(n:n)='"' + call pm_strval(nv,str(n+1:)) + n=n+pm_fast_esize(nv)+2 + str(n:n)='"' + n=n+1 else str(n:)=pm_number_as_string(context,nv,0_pm_ln) endif n=len_trim(str)+1 + str(n:n)='@' + n=n+1 + str(n:)=pm_int_as_string(pm_tv_name(tv)) + n=len_trim(str)+1 endif - case(pm_type_is_const) + case(pm_type_is_fix) if(add_char('fix(')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return + case(pm_type_is_unfixed) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + if(add_char('_literal')) return case(pm_type_is_except) call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(' except ')) return @@ -2911,6 +2984,9 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) if(add_char('<')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char('>')) return + case(pm_type_is_uninitialised) + if(add_char('UNINIT:')) return + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) case(pm_type_is_bottom) if(add_char(' _ ')) return case default @@ -2922,6 +2998,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) include 'fvkind.inc' include 'fisnull.inc' include 'ftiny.inc' + include 'fesize.inc' function add_char(c) result(term) character(len=*),intent(in):: c @@ -3077,7 +3154,7 @@ end subroutine pm_type_error ! Error message for ambiguous match ! (assumes wstack holds results from pm_indirect_include) - subroutine typ_ambiguous_match_error(context,pt,at,at2,wstack,wtop) + subroutine pm_type_ambiguous_match_error(context,pt,at,at2,wstack,wtop) type(pm_context),pointer:: context integer,intent(in):: pt,at,at2,wtop integer,intent(in),dimension(:):: wstack @@ -3097,6 +3174,6 @@ subroutine typ_ambiguous_match_error(context,pt,at,at2,wstack,wtop) wstack(wtop-1)),2))) call more_error(context,' of type: '//& trim(pm_type_as_string(context,wstack(wtop)))) - end subroutine typ_ambiguous_match_error + end subroutine pm_type_ambiguous_match_error end module pm_types diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 314300d..f90930d 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -693,6 +693,35 @@ module pm_vmdefs integer,parameter:: num_op=op_stop_comp + integer,parameter:: op_add_fold=-1 + integer,parameter:: op_sub_fold=-2 + integer,parameter:: op_mult_fold=-3 + integer,parameter:: op_divide_fold=-4 + integer,parameter:: op_div_fold=-5 + integer,parameter:: op_mod_fold=-6 + integer,parameter:: op_pow_fold=-7 + integer,parameter:: op_uminus_fold=-8 + integer,parameter:: op_eq_fold=-9 + integer,parameter:: op_ne_fold=-10 + integer,parameter:: op_gt_fold=-11 + integer,parameter:: op_ge_fold=-12 + integer,parameter:: op_string_fold=-13 + integer,parameter:: op_max_fold = -14 + integer,parameter:: op_min_fold = -15 + integer,parameter:: op_abs_fold = -16 + integer,parameter:: op_band_fold = -17 + integer,parameter:: op_bor_fold = -18 + integer,parameter:: op_bxor_fold = -19 + integer,parameter:: op_bshift_fold = -20 + integer,parameter:: op_bnot_fold = -21 + integer,parameter:: op_pdiff_fold = -22 + integer,parameter:: op_sign_fold = -23 + integer,parameter:: op_modulo_fold = -24 + integer,parameter:: op_and_fold = -25 + integer,parameter:: op_or_fold = -26 + integer,parameter:: op_except_fold = -27 + integer,parameter:: op_concat_fold = -28 + integer,dimension(0:num_op):: op_flags integer,parameter:: op_is_call=1 integer,parameter:: op_is_jump=2 diff --git a/src/wcoder.f90 b/src/wcoder.f90 index dc8d70c..1d0cf26 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -173,8 +173,8 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) wcd%true_obj%data%l(wcd%true_obj%offset)=.true. wcd%false_obj=pm_new_small(context,pm_logical,1_pm_p) wcd%false_obj%data%l(wcd%false_obj%offset)=.false. - wcd%true_name=pm_new_value_type(wcd%context,wcd%true_obj) - wcd%false_name=pm_new_value_type(wcd%context,wcd%false_obj) + wcd%true_name=pm_new_fix_type(wcd%context,wcd%true_obj) + wcd%false_name=pm_new_fix_type(wcd%context,wcd%false_obj) if(pm_is_compiling) then wcd%typeset=pm_set_new(wcd%context,32_pm_ln) endif @@ -1507,7 +1507,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) var_slot(wcd,cnode_arg(args,kk))) enddo endif - case(sym_coherent,sym_partial,sym_set_mode,& + case(sym_coherent,sym_partial,sym_set_mode,sym_const,sym_var,& sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_assignment) continue ! Nothing to do case(sym_cast) @@ -1540,7 +1540,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) endif - case(sym_dash,sym_caret,sym_change_mode,sym_var,sym_const) + case(sym_dash,sym_caret,sym_change_mode) call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) case(sym_import_val,sym_import_shared) @@ -2018,6 +2018,13 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif case(sp_sig_noop) continue + case(sp_sig_setval) + if(.not.pm_is_compiling) then + call wc_call(wcd,callnode,op_setref,0,3,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + call wc(wcd,& + -pm_max_stack-add_const(wcd,pm_type_val(wcd%context,check_arg_type(wcd,args,rv,1)))) + endif case default call wcode_error(wcd,callnode,'System Error!') write(*,*) 'IDX=',idx From a5859dc4d6d4e36c9747ad4944bebcf160239e48 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 6 Jun 2024 11:25:38 +0100 Subject: [PATCH 07/36] More work on split initialisation --- src/codegen.f90 | 8 +- src/infer.f90 | 249 +++++++++++++++++++++++++++--------------------- src/parser.f90 | 27 +----- src/sysdefs.f90 | 2 +- 4 files changed, 149 insertions(+), 137 deletions(-) diff --git a/src/codegen.f90 b/src/codegen.f90 index 259c5ba..e88904d 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -1145,6 +1145,8 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) type(pm_ptr):: cblock2,vlist,v,var integer:: save_par_state + j=push_if_scope(coder) + if(pm_fast_isnull(node_arg(node,2))) then flags=var_is_shadowed+var_is_var call trav_expr(coder,cblock,node,node_arg(node,1)) @@ -1165,6 +1167,7 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) var=top_code(coder) start=coder%index call swap_code(coder) + coder%if_scope=j call trav_open_stmt_list(coder,cblock2,node,node_arg(node,3)) if(cnode_flags_set(var,var_flags,var_is_changed)) then call make_temp_var(coder,cblock2,node) @@ -1188,9 +1191,11 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) v%data%i(v%offset)=start v%data%i(v%offset+1)=finish call make_const(coder,cblock,node,coder%temp) - call make_sp_call(coder,cblock,node,sym_any,3,1) + n=get_if_scope(coder) + call make_sp_call(coder,cblock,node,sym_any,3+n,1) call drop_code(coder) call hide_vars(coder,vb,vb) + call pop_if_scope(coder) coder%par_state=save_par_state contains include 'fisnull.inc' @@ -5160,7 +5165,6 @@ recursive subroutine trav_type_decl(coder,pnode,node) 888 continue coder%wtop=coder%wtop-nargs-1 coder%wstack(coder%wtop)=0 - contains diff --git a/src/infer.f90 b/src/infer.f90 index 7b8bf29..12e72bf 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -1295,117 +1295,9 @@ subroutine prc_call(coder,cblock,callnode,base) call combine_types(cnode_arg(args,1),& pm_new_type_type(coder%context,tno)) case(sym_any) - list2=cnode_arg(args,4) - list2=cnode_arg(list2,1) - slot=list2%data%i(list2%offset) - slot2=list2%data%i(list2%offset+1) - tno=pm_type_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) - t=check_poly(coder,tno) - if(tno/=error_type.and..not.pm_fast_isnull(t)) then - n=pm_set_size(coder%context,t) - do i=1,n - list=pm_set_key(coder%context,t,int(i,pm_ln)) - tno=list%data%i(list%offset) - coder%stack(base+slot:base+slot2)=undefined - coder%stack(get_slot(1))=& - pm_type_add_mode(coder%context,tno,mode,cond) - call prc_cblock(coder,cnode_arg(args,2),base) - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - enddo - call make_code(coder,pm_null_obj,cnode_is_any_sig,n) - list=pop_code(coder) - if(.not.coder%incomplete) then - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - call set_call_sig(int(k)) - endif - else - coder%stack(base+slot:base+slot2)=undefined - call set_arg_to_error_type(1) - call prc_cblock(coder,cnode_arg(args,2),base) - endif + call prc_any(nargs) case(sym_each_proc) ! this controls body for proc.. each() - t=cnode_arg(args,nret+4) - t=cnode_arg(t,1) - slot=t%data%i(t%offset) - slot2=t%data%i(t%offset+1) - tno=arg_type(nret+5) - if(tno<=0) then - do i=1,nret - call set_arg_to_error_type(i) - enddo - return - endif - t=pm_type_vect(coder%context,tno) - tno2=pm_tv_kind(t) - flags=iand(pm_tv_flags(t),pm_type_has_embedded) - name=pm_tv_name(t) - n=nargs-4 - if(tno2==pm_type_is_struct.or.tno2==pm_type_is_rec) then - do i=nret+7,nargs-1,2 - tno=arg_type(i) - t2=pm_type_vect(coder%context,tno) - if(pm_tv_kind(t2)/=tno2) then - if(coder%num_errors==0) & - call infer_error_with_trace(coder,callnode,& - '"proc <>" arguments cannot mix "struct" and "rec"') - endif - if(pm_tv_name(t2)/=name) then - if(coder%num_errors==0) & - call infer_error_with_trace(coder,callnode,& - '"proc <>" arguments must have the same "struct" or "rec" name') - endif - enddo - n=pm_tv_numargs(t) - if(nret>0) then - call check_wstack(coder,nret*(n+2)) - tbase=coder%wtop - coder%wtop=coder%wtop+nret*(n+2) - do i=1,nret - coder%wstack(tbase+(i-1)*(n+2)+1)=ior(tno2,flags) - coder%wstack(tbase+(i-1)*(n+2)+2)=name - enddo - endif - do i=1,n - do j=nret+5,nargs-1,2 - tno=arg_type(j) - t2=pm_type_vect(coder%context,tno) - tno=pm_tv_arg(t2,i) - coder%stack(get_slot(j+1))=tno - enddo - call prc_cblock(coder,cnode_arg(args,nret+3),base) - do j=1,nret - coder%wstack(tbase+(j-1)*(n+2)+i+2)=arg_type(nargs+j) - enddo - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - enddo - call make_code(coder,pm_null_obj,cnode_is_any_sig,n) - list=pop_code(coder) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - slot=cnode_get_num(callnode,call_index) - coder%stack(base+slot)=k - tno3=pm_type_from_recorded_name(coder%context,name) - do i=nret,1,-1 - call make_type_if_possible(coder,n+2) - if(.not.pm_type_includes(coder%context,tno3,tno2,pm_type_incl_val,einfo)) then - call infer_error(coder,args,& - '"'//trim(sym_names(tno2))//& - '" initial expression has wrong type for: ',& - pm_fast_name(coder%context,name)) - call pm_type_error(coder%context,einfo) - call infer_trace(coder) - endif - coder%stack(get_slot(i))=pop_word(coder) - enddo - call prc_cblock(coder,cnode_arg(args,nret+1),base) - else - call prc_cblock(coder,cnode_arg(args,nret+2),base) - slot=cnode_get_num(callnode,call_index) - coder%stack(base+slot)=0 - endif + call prc_each_proc case(sym_test) call prc_cblock(coder,cnode_arg(args,1),base) case(sym_check) @@ -1607,7 +1499,142 @@ subroutine prc_if(nargs) call prc_cblock(coder,cnode_arg(args,3),base) endif end subroutine prc_if - + + subroutine prc_any(nargs) + integer,intent(in):: nargs + integer,dimension(5:nargs+1):: init_args,final_args + integer:: i,j,slot,slot2 + type(pm_ptr):: list,list2 + list2=cnode_arg(args,4) + list2=cnode_arg(list2,1) + slot=list2%data%i(list2%offset) + slot2=list2%data%i(list2%offset+1) + tno=pm_type_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) + t=check_poly(coder,tno) + if(tno/=error_type.and..not.pm_fast_isnull(t)) then + n=pm_set_size(coder%context,t) + do j=5,nargs+1 + init_args(j)=arg_type_with_mode(j) + end do + do i=1,n + do j=5,nargs+1 + call set_arg_to_type(j,init_args(j)) + end do + list=pm_set_key(coder%context,t,int(i,pm_ln)) + tno=list%data%i(list%offset) + coder%stack(base+slot:base+slot2)=undefined + coder%stack(get_slot(1))=& + pm_type_add_mode(coder%context,tno,mode,cond) + call prc_cblock(coder,cnode_arg(args,2),base) + call code_int_vec(coder,coder%stack,base+slot,base+slot2) + + if(i>1) then + do j=5,nargs+1 + call combine_arg_types(j,final_args(j),no_init=.true.) + end do + endif + do j=5,nargs+1 + final_args(j)=arg_type_with_mode(j) + end do + enddo + call make_code(coder,pm_null_obj,cnode_is_any_sig,n) + list=pop_code(coder) + if(.not.coder%incomplete) then + key(1)=pm_dict_size(coder%context,coder%proc_cache) + k=pm_idict_add(coder%context,coder%proc_cache,& + key,1,list) + call set_call_sig(int(k)) + endif + else + coder%stack(base+slot:base+slot2)=undefined + call set_arg_to_error_type(1) + call prc_cblock(coder,cnode_arg(args,2),base) + endif + end subroutine prc_any + + subroutine prc_each_proc + t=cnode_arg(args,nret+4) + t=cnode_arg(t,1) + slot=t%data%i(t%offset) + slot2=t%data%i(t%offset+1) + tno=arg_type(nret+5) + if(tno<=0) then + do i=1,nret + call set_arg_to_error_type(i) + enddo + return + endif + t=pm_type_vect(coder%context,tno) + tno2=pm_tv_kind(t) + flags=iand(pm_tv_flags(t),pm_type_has_embedded) + name=pm_tv_name(t) + n=nargs-4 + if(tno2==pm_type_is_struct.or.tno2==pm_type_is_rec) then + do i=nret+7,nargs-1,2 + tno=arg_type(i) + t2=pm_type_vect(coder%context,tno) + if(pm_tv_kind(t2)/=tno2) then + if(coder%num_errors==0) & + call infer_error_with_trace(coder,callnode,& + '"proc <>" arguments cannot mix "struct" and "rec"') + endif + if(pm_tv_name(t2)/=name) then + if(coder%num_errors==0) & + call infer_error_with_trace(coder,callnode,& + '"proc <>" arguments must have the same "struct" or "rec" name') + endif + enddo + n=pm_tv_numargs(t) + if(nret>0) then + call check_wstack(coder,nret*(n+2)) + tbase=coder%wtop + coder%wtop=coder%wtop+nret*(n+2) + do i=1,nret + coder%wstack(tbase+(i-1)*(n+2)+1)=ior(tno2,flags) + coder%wstack(tbase+(i-1)*(n+2)+2)=name + enddo + endif + do i=1,n + do j=nret+5,nargs-1,2 + tno=arg_type(j) + t2=pm_type_vect(coder%context,tno) + tno=pm_tv_arg(t2,i) + coder%stack(get_slot(j+1))=tno + enddo + call prc_cblock(coder,cnode_arg(args,nret+3),base) + do j=1,nret + coder%wstack(tbase+(j-1)*(n+2)+i+2)=arg_type(nargs+j) + enddo + call code_int_vec(coder,coder%stack,base+slot,base+slot2) + enddo + call make_code(coder,pm_null_obj,cnode_is_any_sig,n) + list=pop_code(coder) + key(1)=pm_dict_size(coder%context,coder%proc_cache) + k=pm_idict_add(coder%context,coder%proc_cache,& + key,1,list) + slot=cnode_get_num(callnode,call_index) + coder%stack(base+slot)=k + tno3=pm_type_from_recorded_name(coder%context,name) + do i=nret,1,-1 + call make_type_if_possible(coder,n+2) + if(.not.pm_type_includes(coder%context,tno3,tno2,pm_type_incl_val,einfo)) then + call infer_error(coder,args,& + '"'//trim(sym_names(tno2))//& + '" initial expression has wrong type for: ',& + pm_fast_name(coder%context,name)) + call pm_type_error(coder%context,einfo) + call infer_trace(coder) + endif + coder%stack(get_slot(i))=pop_word(coder) + enddo + call prc_cblock(coder,cnode_arg(args,nret+1),base) + else + call prc_cblock(coder,cnode_arg(args,nret+2),base) + slot=cnode_get_num(callnode,call_index) + coder%stack(base+slot)=0 + endif + end subroutine prc_each_proc + !=================================================================== ! Push argument types with modes for all arguments !================================================================== diff --git a/src/parser.f90 b/src/parser.f90 index caef8b9..506aabe 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -3221,7 +3221,8 @@ recursive subroutine stmt_list(parser,single) if(subexpr(parser)) goto 999 endif case(sym_var,sym_const) - if(assn_list()) goto 999 + if(var_stmt(parser)) goto 999 + if(subexpr(parser)) goto 999 case(sym_coherent,sym_chan,sym_mirrored,sym_shared) call scan(parser) if(mode_stmt(parser,sym)) goto 999 @@ -3284,7 +3285,8 @@ recursive subroutine stmt_list(parser,single) if(subexpr(parser)) goto 999 else call push_back_name(parser,name) - if(assn_list()) goto 999 + if(assn_or_call(parser,.true.,.true.,.true.)) goto 999 + if(subexpr(parser)) goto 999 endif else if(parser%sym>0.and.parser%sym/=sym_close_brace& @@ -3318,27 +3320,6 @@ recursive subroutine stmt_list(parser,single) contains - ! assignment { ',' assignment } - function assn_list() result(iserr) - logical:: iserr - integer:: n - iserr=.true. - n=0 - do - if(parser%sym==sym_var.or.parser%sym==sym_const) then - if(var_stmt(parser)) return - else - if(assn_or_call(parser,.true.,.true.,.true.)) return - endif - n=n+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - if(n>1) call make_node(parser,sym_assign_list,n) - if(subexpr(parser)) return - iserr=.false. - end function assn_list - ! sync name [ qual ] = expr function sync_assign() result(iserr) logical:: iserr diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index a289ec9..f098f2a 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -5790,7 +5790,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any) {check_assign_types(a,b);_assign(&a,b)}',line) + 'PM__assign(&a:any,b:any) {_assign(&a,c) where c=b as a}',line) call dcl_type(parser,& 'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) call dcl_uproc(parser,& From 63567cffced278e6daa0e6f8451fdb561253b4cf Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 19 Jul 2024 15:10:25 +0100 Subject: [PATCH 08/36] Refactor keyword arguments --- pm/lib/sys/pm.pmm | 5276 +++++++++++++++++++++++++++++++++++++ pm/lib/sys/pm_b4.pmm | 5268 +++++++++++++++++++++++++++++++++++++ src/array.f90 | 47 +- src/ast.f90 | 7 +- src/cfortran.f90 | 6 +- src/cnodes.f90 | 209 +- src/codegen.f90 | 3787 ++++++++------------------- src/deadcode.f90 | 1 - src/infer.f90 | 3087 +++++++++++----------- src/lib.f90 | 15 +- src/main.f90 | 24 +- src/opts.f90 | 29 +- src/parser.f90 | 552 ++-- src/symbol.f90 | 46 +- src/sysdefs.f90 | 1073 ++++---- src/sysdefs_make.f90 | 5917 ++++++++++++++++++++++++++++++++++++++++++ src/types.f90 | 188 +- src/vm.f90 | 29 +- src/vmdefs.f90 | 54 +- src/wcoder.f90 | 344 ++- 20 files changed, 20678 insertions(+), 5281 deletions(-) create mode 100644 pm/lib/sys/pm.pmm create mode 100644 pm/lib/sys/pm_b4.pmm create mode 100755 src/sysdefs_make.f90 diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm new file mode 100644 index 0000000..2ec47d1 --- /dev/null +++ b/pm/lib/sys/pm.pmm @@ -0,0 +1,5276 @@ +/* + PM (Parallel Models) Programming Language + + Released under the MIT License (MIT) + Copyright (c) Tim Bellerby, 2024 + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + + +/* +type int_literal is ^^^int +type real_literal is ^^^real +type bool_literal is ^^^bool +type string_literal is ^^^string +*/ + +//type literal is ^^^any + +PM__intrinsic num_elements(any)->(literal(int)) : "num_elems_fold" + +PM__intrinsic mod(literal(int),literal(int))->(literal(int)) : "mod_fold" +PM__intrinsic ==(literal(int),literal(int))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(int),literal(int))->(literal(bool)) : "ne_fold" +PM__intrinsic >=(literal(int),literal(int))->(literal(bool)) : "ge_fold" +PM__intrinsic >(literal(int),literal(int))->(literal(bool)) : "gt_fold" +PM__intrinsic +(literal(int),literal(int))->(literal(int)) : "add_fold" +PM__intrinsic -(literal(int),literal(int))->(literal(int)) : "sub_fold" +PM__intrinsic *(literal(int),literal(int))->(literal(int)) : "mult_fold" +PM__intrinsic /(literal(int),literal(int))->(literal(int)) : "divide_fold" +PM__intrinsic **(literal(int),literal(int))->(literal(int)) : "pow_fold" +PM__intrinsic max(literal(int),literal(int))->(literal(int)) : "max_fold" +PM__intrinsic min(literal(int),literal(int))->(literal(int)) : "min_fold" +PM__intrinsic -(literal(int))->(literal(int)) : "uminus_fold" +PM__intrinsic string(literal(int))->(literal(string)) : "string_fold" +PM__intrinsic abs(literal(int))->(literal(int)) : "abs_fold" +PM__intrinsic ~(literal(int))->(literal(int)) : "bnot_fold" +PM__intrinsic &(literal(int),literal(int))->(literal(int)) : "band_fold" +PM__intrinsic |(literal(int),literal(int))->(literal(int)) : "bor_fold" +PM__intrinsic xor(literal(int),literal(int))->(literal(int)) : "bxor_fold" +PM__intrinsic shift(literal(int),literal(int))->(literal(int)) : "bshift_fold" +PM__intrinsic pdiff(literal(int),literal(int))->(literal(int)) : "pdiff_fold" +PM__intrinsic sign(literal(int),literal(int))->(literal(int)) : "sign_fold" +PM__intrinsic rem(literal(int),literal(int))->(literal(int)) : "modulo_fold" +PM__intrinsic and(literal(bool),literal(bool))->(literal(bool)) : "and_fold" +PM__intrinsic or(literal(bool),literal(bool))->(literal(bool)) : "or_fold" +PM__intrinsic except(literal(bool),literal(bool))->(literal(bool)) : "except_fold" +PM__intrinsic ==(literal(bool),literal(bool))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(bool),literal(bool))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(string),literal(string))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(string),literal(string))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(real),literal(real))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(real),literal(real))->(literal(bool)) : "ne_fold" +PM__intrinsic ++(literal(string),literal(string))->(literal(string)) : "concat_fold" +PM__intrinsic mod(fix(int),fix(int))->(fix(int)) : "mod_fold" +PM__intrinsic ==(fix(int),fix(int))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(int),fix(int))->(fix(bool)) : "ne_fold" +PM__intrinsic >=(fix(int),fix(int))->(fix(bool)) : "ge_fold" +PM__intrinsic >(fix(int),fix(int))->(fix(bool)) : "gt_fold" +PM__intrinsic +(fix(int),fix(int))->(fix(int)) : "add_fold" +PM__intrinsic -(fix(int),fix(int))->(fix(int)) : "sub_fold" +PM__intrinsic *(fix(int),fix(int))->(fix(int)) : "mult_fold" +PM__intrinsic /(fix(int),fix(int))->(fix(int)) : "divide_fold" +PM__intrinsic **(fix(int),fix(int))->(fix(int)) : "pow_fold" +PM__intrinsic max(fix(int),fix(int))->(fix(int)) : "max_fold" +PM__intrinsic min(fix(int),fix(int))->(fix(int)) : "min_fold" +PM__intrinsic -(fix(int))->(fix(int)) : "uminus_fold" +PM__intrinsic string(fix(int))->(fix(string)) : "string_fold" +PM__intrinsic abs(fix(int))->(fix(int)) : "abs_fold" +PM__intrinsic ~(fix(int))->(fix(int)) : "bnot_fold" +PM__intrinsic &(fix(int),fix(int))->(fix(int)) : "band_fold" +PM__intrinsic |(fix(int),fix(int))->(fix(int)) : "bor_fold" +PM__intrinsic xor(fix(int),fix(int))->(fix(int)) : "bxor_fold" +PM__intrinsic shift(fix(int),fix(int))->(fix(int)) : "bshift_fold" +PM__intrinsic pdiff(fix(int),fix(int))->(fix(int)) : "pdiff_fold" +PM__intrinsic sign(fix(int),fix(int))->(fix(int)) : "sign_fold" +PM__intrinsic rem(fix(int),fix(int))->(fix(int)) : "modulo_fold" +PM__intrinsic and(fix(bool),fix(bool))->(fix(bool)) : "and_fold" +PM__intrinsic or(fix(bool),fix(bool))->(fix(bool)) : "or_fold" +PM__intrinsic except(fix(bool),fix(bool))->(fix(bool)) : "except_fold" +PM__intrinsic ==(fix(bool),fix(bool))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(bool),fix(bool))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(string),fix(string))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(string),fix(string))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(real),fix(real))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(real),fix(real))->(fix(bool)) : "ne_fold" +PM__intrinsic ++(fix(string),fix(string))->(fix(string)) : "concat_fold" + +// ************************************** +// BASIC TYPES +// ************************************** + +// String type +PM__intrinsic<> print(string): "print" + +proc print(x) { + print(string(x)) +} + +PM__intrinsic<> print_all(string): "print"(1) + +proc print_all(x) { + print_all(string(x)) +} + +PM__intrinsic ++(string,string)->(string) : "concat" + +proc ++(x:string,y)=$++.(x,string(y)) +proc ++(x,y)=$++.(string(x),string(y)) +proc string(x:string)=x +proc string(x:null)="null" +proc fmt(x,y)=x:test """fmt"" operator not yet implmented"=>fix(false) + +// sint type +PM__intrinsic PM__assign_var(&sint,sint): "assign_i" +PM__intrinsic mod(sint,sint)->(sint) : "mod_i" +PM__intrinsic ==(sint,sint)->(bool) : "eq_i" +PM__intrinsic /=(sint,sint)->(bool) : "ne_i" +PM__intrinsic >=(sint,sint)->(bool) : "ge_i" +PM__intrinsic >(sint,sint)->(bool) : "gt_i" +PM__intrinsic +(sint,sint)->(sint) : "add_i" +PM__intrinsic -(sint,sint)->(sint) : "sub_i" +PM__intrinsic *(sint,sint)->(sint) : "mult_i" +PM__intrinsic /(sint,sint)->(sint) : "divide_i" +PM__intrinsic **(sint,sint)->(sint) : "pow_i" +PM__intrinsic max(sint,sint)->(sint) : "max_i" +PM__intrinsic min(sint,sint)->(sint) : "min_i" +PM__intrinsic -(sint)->(sint) : "uminus_i" +PM__intrinsic string(sint)->(string) : "string_i" +PM__intrinsic int(sint)->(int) : "long_i" +PM__intrinsic sreal(sint)->(sreal) : "real_i" +PM__intrinsic real(sint)->(real) : "double_i" +proc sint(x:sint)=x +PM__intrinsic abs(sint)->(sint) : "abs_i" +PM__intrinsic bit_not(sint)->(sint) : "bnot_i" +PM__intrinsic &(sint,sint)->(sint) : "band_i" +PM__intrinsic |(sint,sint)->(sint) : "bor_i" +PM__intrinsic xor(sint,sint)->(sint) : "bxor_i" +PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" +PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" +PM__intrinsic sign(sint,sint)->(sint) : "sign_i" +PM__intrinsic rem(sint,sint)->(sint) : "modulo_i" +PM__intrinsic int8(sint)->(int8) : "i8_i" +PM__intrinsic int16(sint)->(int16) : "i16_i" +PM__intrinsic int32(sint)->(int32) : "i32_i" +PM__intrinsic int64(sint)->(int64) : "i64_i" +PM__intrinsic lint(sint)->(lint) : "offset_i" + +// int type +PM__intrinsic PM__assign_var(&int,int): "assign_ln" +PM__intrinsic mod(int,int)->(int) : "mod_ln" +PM__intrinsic ==(int,int)->(bool) : "eq_ln" +PM__intrinsic /=(int,int)->(bool) : "ne_ln" +PM__intrinsic >=(int,int)->(bool) : "ge_ln" +PM__intrinsic >(int,int)->(bool) : "gt_ln" +PM__intrinsic +(int,int)->(int) : "add_ln" +PM__intrinsic -(int,int)->(int) : "sub_ln" +PM__intrinsic *(int,int)->(int) : "mult_ln" +proc *(x:int,y:fix(1))=x +PM__intrinsic /(int,int)->(int) : "divide_ln" +proc /(x:int,y:fix(1))=x +PM__intrinsic **(int,int)->(int) : "pow_ln" +PM__intrinsic max(int,int)->(int) : "max_ln" +PM__intrinsic min(int,int)->(int) : "min_ln" +PM__intrinsic -(int)->(int) : "uminus_ln" +PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic sint(int)->(sint) : "int_ln" +PM__intrinsic sreal(int)->(sreal) : "real_ln" +PM__intrinsic real(int)->(real) : "double_ln" +proc int(x:int)=x +PM__intrinsic abs(int)->(int) : "abs_ln" +PM__intrinsic ~(int)->(int) : "bnot_ln" +PM__intrinsic &(int,int)->(int) : "band_ln" +PM__intrinsic |(int,int)->(int) : "bor_ln" +PM__intrinsic xor(int,int)->(int) : "bxor_ln" +PM__intrinsic shift(int,int)->(int) : "bshift_ln" +PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" +PM__intrinsic sign(int,int)->(int) : "sign_ln" +PM__intrinsic rem(int,int)->(int) : "modulo_ln" +PM__intrinsic int8(int)->(int8) : "i8_ln" +PM__intrinsic int16(int)->(int16) : "i16_ln" +PM__intrinsic int32(int)->(int32) : "i32_ln" +PM__intrinsic int64(int)->(int64) : "i64_ln" +PM__intrinsic lint(int)->(lint) : "offset_ln" + +// lint type +PM__intrinsic PM__assign_var(&lint,lint): "assign_offset" +PM__intrinsic mod(lint,lint)->(lint) : "mod_offset" +PM__intrinsic ==(lint,lint)->(bool) : "eq_offset" +PM__intrinsic /=(lint,lint)->(bool) : "ne_offset" +PM__intrinsic >=(lint,lint)->(bool) : "ge_offset" +PM__intrinsic >(lint,lint)->(bool) : "gt_offset" +PM__intrinsic +(lint,lint)->(lint) : "add_offset" +proc +(x:lint,y:fix(0))=x +proc +(x:fix(0),y:lint)=y +PM__intrinsic -(lint,lint)->(lint) : "sub_offset" +proc -(x:lint,y:fix(0))=x +PM__intrinsic *(lint,lint)->(lint) : "mult_offset" +proc *(x:lint,y:fix(1))=x +proc *(x:fix(1),y:lint)=y +PM__intrinsic /(lint,lint)->(lint) : "divide_offset" +proc /(x:lint,y:fix(1))=x +PM__intrinsic **(lint,lint)->(lint) : "pow_offset" +proc **(x:lint,y:fix(0))=1 +proc **(x:lint,y:fix(1))=x +proc **(x:lint,y:fix(2))=x*x +PM__intrinsic max(lint,lint)->(lint) : "max_offset" +PM__intrinsic min(lint,lint)->(lint) : "min_offset" +PM__intrinsic -(lint)->(lint) : "uminus_offset" +PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic sint(lint)->(sint) : "int_offset" +PM__intrinsic sreal(lint)->(sreal) : "real_offset" +PM__intrinsic real(lint)->(real) : "double_offset" +proc lint(x:lint)=x +PM__intrinsic abs(lint)->(lint) : "abs_offset" +PM__intrinsic ~(lint)->(lint) : "bnot_offset" +PM__intrinsic &(lint,lint)->(lint) : "band_offset" +PM__intrinsic |(lint,lint)->(lint) : "bor_offset" +PM__intrinsic xor(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" +PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" +PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" +PM__intrinsic rem(lint,lint)->(lint) : "modulo_offset" +PM__intrinsic int8(lint)->(int8) : "i8_offset" +PM__intrinsic int16(lint)->(int16) : "i16_offset" +PM__intrinsic int32(lint)->(int32) : "i32_offset" +PM__intrinsic int64(lint)->(int64) : "i64_offset" +PM__intrinsic int(lint)->(int) : "long_offset" + +// int8 type +PM__intrinsic PM__assign_var(&int8,int8): "assign_i8" +PM__intrinsic mod(int8,int8)->(int8) : "mod_i8" +PM__intrinsic ==(int8,int8)->(bool) : "eq_i8" +PM__intrinsic /=(int8,int8)->(bool) : "ne_i8" +PM__intrinsic >=(int8,int8)->(bool) : "ge_i8" +PM__intrinsic >(int8,int8)->(bool) : "gt_i8" +PM__intrinsic +(int8,int8)->(int8) : "add_i8" +proc +(x:int8,y:fix(0))=x +proc +(x:fix(0),y:int8)=y +PM__intrinsic -(int8,int8)->(int8) : "sub_i8" +proc -(x:int8,y:fix(0))=x +PM__intrinsic *(int8,int8)->(int8) : "mult_i8" +proc *(x:int8,y:fix(1))=x +proc *(x:fix(1),y:int8)=y +PM__intrinsic /(int8,int8)->(int8) : "divide_i8" +proc /(x:int8,y:fix(1))=x +PM__intrinsic **(int8,int8)->(int8) : "pow_i8" +proc **(x:int8,y:fix(0))=1 +proc **(x:int8,y:fix(1))=x +proc **(x:int8,y:fix(2))=x*x +PM__intrinsic max(int8,int8)->(int8) : "max_i8" +PM__intrinsic min(int8,int8)->(int8) : "min_i8" +PM__intrinsic -(int8)->(int8) : "uminus_i8" +PM__intrinsic sint(int8)->(sint) : "int_i8" +PM__intrinsic sreal(int8)->(sreal) : "real_i8" +PM__intrinsic real(int8)->(real) : "double_i8" +proc int8(x:int8)=x +PM__intrinsic abs(int8)->(int8) : "abs_i8" +PM__intrinsic ~(int8)->(int8) : "bnot_i8" +PM__intrinsic &(int8,int8)->(int8) : "band_i8" +PM__intrinsic |(int8,int8)->(int8) : "bor_i8" +PM__intrinsic xor(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" +PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" +PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" +PM__intrinsic rem(int8,int8)->(int8) : "modulo_i8" +PM__intrinsic int16(int8)->(int16) : "i16_i8" +PM__intrinsic int32(int8)->(int32) : "i32_i8" +PM__intrinsic int64(int8)->(int64) : "i64_i8" +PM__intrinsic int(int8)->(int) : "long_i8" +PM__intrinsic lint(int8)->(lint) : "offset_i8" + +// int16 type +PM__intrinsic PM__assign_var(&int16,int16): "assign_i16" +PM__intrinsic mod(int16,int16)->(int16) : "mod_i16" +PM__intrinsic ==(int16,int16)->(bool) : "eq_i16" +PM__intrinsic /=(int16,int16)->(bool) : "ne_i16" +PM__intrinsic >=(int16,int16)->(bool) : "ge_i16" +PM__intrinsic >(int16,int16)->(bool) : "gt_i16" +PM__intrinsic +(int16,int16)->(int16) : "add_i16" +proc +(x:int16,y:fix(0))=x +proc +(x:fix(0),y:int16)=y +PM__intrinsic -(int16,int16)->(int16) : "sub_i16" +proc -(x:int16,y:fix(0))=x +PM__intrinsic *(int16,int16)->(int16) : "mult_i16" +proc *(x:int16,y:fix(1))=x +proc *(x:fix(1),y:int16)=y +PM__intrinsic /(int16,int16)->(int16) : "divide_i16" +proc /(x:int16,y:fix(1))=x +PM__intrinsic **(int16,int16)->(int16) : "pow_i16" +proc **(x:int16,y:fix(0))=1 +proc **(x:int16,y:fix(1))=x +proc **(x:int16,y:fix(2))=x*x +PM__intrinsic max(int16,int16)->(int16) : "max_i16" +PM__intrinsic min(int16,int16)->(int16) : "min_i16" +PM__intrinsic -(int16)->(int16) : "uminus_i16" +PM__intrinsic sint(int16)->(sint) : "int_i16" +PM__intrinsic sreal(int16)->(sreal) : "real_i16" +PM__intrinsic real(int16)->(real) : "double_i16" +proc int16(x:int16)=x +PM__intrinsic abs(int16)->(int16) : "abs_i16" +PM__intrinsic ~(int16)->(int16) : "bnot_i16" +PM__intrinsic &(int16,int16)->(int16) : "band_i16" +PM__intrinsic |(int16,int16)->(int16) : "bor_i16" +PM__intrinsic xor(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" +PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" +PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" +PM__intrinsic rem(int16,int16)->(int16) : "modulo_i16" +PM__intrinsic int8(int16)->(int16) : "i8_i16" +PM__intrinsic int32(int16)->(int32) : "i32_i16" +PM__intrinsic int64(int16)->(int64) : "i64_i16" +PM__intrinsic int(int16)->(int) : "long_i16" +PM__intrinsic lint(int16)->(lint) : "offset_i16" + +// int32 type +PM__intrinsic PM__assign_var(&int32,int32): "assign_i32" +PM__intrinsic mod(int32,int32)->(int32) : "mod_i32" +PM__intrinsic ==(int32,int32)->(bool) : "eq_i32" +PM__intrinsic /=(int32,int32)->(bool) : "ne_i32" +PM__intrinsic >=(int32,int32)->(bool) : "ge_i32" +PM__intrinsic >(int32,int32)->(bool) : "gt_i32" +PM__intrinsic +(int32,int32)->(int32) : "add_i32" +proc +(x:int32,y:fix(0))=x +proc +(x:fix(0),y:int32)=y +PM__intrinsic -(int32,int32)->(int32) : "sub_i32" +proc -(x:int32,y:fix(0))=x +PM__intrinsic *(int32,int32)->(int32) : "mult_i32" +proc *(x:int32,y:fix(1))=x +proc *(x:fix(1),y:int32)=y +PM__intrinsic /(int32,int32)->(int32) : "divide_i32" +proc /(x:int32,y:fix(1))=x +PM__intrinsic **(int32,int32)->(int32) : "pow_i32" +proc **(x:int32,y:fix(0))=1 +proc **(x:int32,y:fix(1))=x +proc **(x:int32,y:fix(2))=x*x +PM__intrinsic max(int32,int32)->(int32) : "max_i32" +PM__intrinsic min(int32,int32)->(int32) : "min_i32" +PM__intrinsic -(int32)->(int32) : "uminus_i32" +PM__intrinsic sint(int32)->(sint) : "int_i32" +PM__intrinsic sreal(int32)->(sreal) : "real_i32" +PM__intrinsic real(int32)->(real) : "double_i32" +proc int32(x:int32)=x +PM__intrinsic abs(int32)->(int32) : "abs_i32" +PM__intrinsic ~(int32)->(int32) : "bnot_i32" +PM__intrinsic &(int32,int32)->(int32) : "band_i32" +PM__intrinsic |(int32,int32)->(int32) : "bor_i32" +PM__intrinsic xor(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" +PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" +PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" +PM__intrinsic rem(int32,int32)->(int32) : "modulo_i32" +PM__intrinsic int8(int32)->(int32) : "i8_i32" +PM__intrinsic int16(int32)->(int32) : "i16_i32" +PM__intrinsic int64(int32)->(int64) : "i64_i32" +PM__intrinsic int(int32)->(int) : "long_i32" +PM__intrinsic lint(int32)->(lint) : "offset_i32" + +// int64 type +PM__intrinsic PM__assign_var(&int64,int64): "assign_i64" +PM__intrinsic mod(int64,int64)->(int64) : "mod_i64" +PM__intrinsic ==(int64,int64)->(bool) : "eq_i64" +PM__intrinsic /=(int64,int64)->(bool) : "ne_i64" +PM__intrinsic >=(int64,int64)->(bool) : "ge_i64" +PM__intrinsic >(int64,int64)->(bool) : "gt_i64" +PM__intrinsic +(int64,int64)->(int64) : "add_i64" +proc +(x:int64,y:fix(0))=x +proc +(x:fix(0),y:int64)=y +PM__intrinsic -(int64,int64)->(int64) : "sub_i64" +proc -(x:int64,y:fix(0))=x +PM__intrinsic *(int64,int64)->(int64) : "mult_i64" +proc *(x:int64,y:fix(1))=x +proc *(x:fix(1),y:int64)=y +PM__intrinsic /(int64,int64)->(int64) : "divide_i64" +proc /(x:int64,y:fix(1))=x +PM__intrinsic **(int64,int64)->(int64) : "pow_i64" +proc **(x:int64,y:fix(0))=1 +proc **(x:int64,y:fix(1))=x +proc **(x:int64,y:fix(2))=x*x +PM__intrinsic max(int64,int64)->(int64) : "max_i64" +PM__intrinsic min(int64,int64)->(int64) : "min_i64" +PM__intrinsic -(int64)->(int64) : "uminus_i64" +PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic sint(int64)->(sint) : "int_i64" +PM__intrinsic sreal(int64)->(sreal) : "real_i64" +PM__intrinsic real(int64)->(real) : "double_i64" +proc int64(x:int64)=x +PM__intrinsic abs(int64)->(int64) : "abs_i64" +PM__intrinsic ~(int64)->(int64) : "bnot_i64" +PM__intrinsic &(int64,int64)->(int64) : "band_i64" +PM__intrinsic |(int64,int64)->(int64) : "bor_i64" +PM__intrinsic xor(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" +PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" +PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" +PM__intrinsic rem(int64,int64)->(int64) : "modulo_i64" +PM__intrinsic int8(int64)->(int64) : "i8_i64" +PM__intrinsic int16(int64)->(int64) : "i16_i64" +PM__intrinsic int32(int64)->(int64) : "i32_i64" +PM__intrinsic int(int64)->(int) : "long_i64" +PM__intrinsic lint(int64)->(lint) : "offset_i64" + +// sreal type +PM__intrinsic PM__assign_var(&sreal,sreal): "assign_r" +PM__intrinsic mod(sreal,sreal)->(sreal) : "mod_r" +PM__intrinsic ==(sreal,sreal)->(bool) : "eq_r" +PM__intrinsic /=(sreal,sreal)->(bool) : "ne_r" +PM__intrinsic >=(sreal,sreal)->(bool) : "ge_r" +PM__intrinsic >(sreal,sreal)->(bool) : "gt_r" +PM__intrinsic +(sreal,sreal)->(sreal) : "add_r" +PM__intrinsic -(sreal,sreal)->(sreal) : "sub_r" +PM__intrinsic *(sreal,sreal)->(sreal) : "mult_r" +PM__intrinsic /(sreal,sreal)->(sreal) : "divide_r" +PM__intrinsic **(sreal,sreal)->(sreal) : "pow_r" +PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" +PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" +PM__intrinsic -(sreal)->(sreal) : "uminus_r" +PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic strunc(sreal)->(sint) : "int_r" +PM__intrinsic trunc(sreal)->(int) : "long_r" +PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" +PM__intrinsic real(sreal)->(real) : "double_r" +proc sreal(x:sreal)=x +PM__intrinsic abs(sreal)->(sreal) : "abs_r" +PM__intrinsic acos(sreal)->(sreal) : "acos_r" +PM__intrinsic asin(sreal)->(sreal) : "asin_r" +PM__intrinsic atan(sreal)->(sreal) : "atan_r" +PM__intrinsic atan2(sreal,sreal)->(sreal) : "atan2_r" +PM__intrinsic cos(sreal)->(sreal) : "cos_r" +PM__intrinsic cosh(sreal)->(sreal) : "cosh_r" +PM__intrinsic exp(sreal)->(sreal) : "exp_r" +PM__intrinsic log(sreal)->(sreal) : "log_r" +PM__intrinsic log10(sreal)->(sreal) : "log10_r" +PM__intrinsic sin(sreal)->(sreal) : "sin_r" +PM__intrinsic sinh(sreal)->(sreal) : "sinh_r" +PM__intrinsic sqrt(sreal)->(sreal) : "sqrt_r" +PM__intrinsic tan(sreal)->(sreal) : "tan_r" +PM__intrinsic tanh(sreal)->(sreal) : "tanh_r" +PM__intrinsic floor(sreal)->(sreal) : "floor_r" +PM__intrinsic ceil(sreal)->(sreal) : "ceil_r" +PM__intrinsic rem(sreal,sreal)->(sreal) : "modulo_r" +PM__intrinsic sign(sreal,sreal)->(sreal) : "sign_r" +PM__intrinsic pdiff(sreal,sreal)->(sreal) : "pdiff_r" +PM__intrinsic lint(sreal)->(lint) : "offset_r" +PM__intrinsic scpx(sreal)->(scpx) : "complex_r" +PM__intrinsic _scpx2(sreal,sreal)->(scpx) : "complex2_r" +proc scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y)) + +// real type +PM__intrinsic PM__assign_var(&real,real): "assign_d" +PM__intrinsic mod(real,real)->(real) : "mod_d" +PM__intrinsic ==(real,real)->(bool) : "eq_d" +PM__intrinsic /=(real,real)->(bool) : "ne_d" +PM__intrinsic >=(real,real)->(bool) : "ge_d" +PM__intrinsic >(real,real)->(bool) : "gt_d" +PM__intrinsic +(real,real)->(real) : "add_d" +PM__intrinsic -(real,real)->(real) : "sub_d" +PM__intrinsic *(real,real)->(real) : "mult_d" +PM__intrinsic /(real,real)->(real) : "divide_d" +PM__intrinsic **(real,real)->(real) : "pow_d" +PM__intrinsic max(real,real)->(real) : "max_d" +PM__intrinsic min(real,real)->(real) : "min_d" +PM__intrinsic -(real)->(real) : "uminus_d" +PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic strunc(real)->(sint) : "int_d" +PM__intrinsic trunc(real)->(int) : "long_d" +PM__intrinsic ltrunc(real)->(lint) : "offset_d" +PM__intrinsic sreal(real)->(sreal) : "real_d" +proc real(x:real)=x +PM__intrinsic abs(real)->(real) : "abs_d" +PM__intrinsic acos(real)->(real) : "acos_d" +PM__intrinsic asin(real)->(real) : "asin_d" +PM__intrinsic atan(real)->(real) : "atan_d" +PM__intrinsic atan2(real,real)->(real) : "atan2_d" +PM__intrinsic cos(real)->(real) : "cos_d" +PM__intrinsic cosh(real)->(real) : "cosh_d" +PM__intrinsic exp(real)->(real) : "exp_d" +PM__intrinsic log(real)->(real) : "log_d" +PM__intrinsic log10(real)->(real) : "log10_d" +PM__intrinsic sin(real)->(real) : "sin_d" +PM__intrinsic sinh(real)->(real) : "sinh_d" +PM__intrinsic sqrt(real)->(real) : "sqrt_d" +PM__intrinsic tan(real)->(real) : "tan_d" +PM__intrinsic tanh(real)->(real) : "tanh_d" +PM__intrinsic floor(real)->(real) : "floor_d" +PM__intrinsic ceil(real)->(real) : "ceil_d" +PM__intrinsic rem(real,real)->(real) : "modulo_d" +PM__intrinsic sign(real,real)->(real) : "sign_d" +PM__intrinsic pdiff(real,real)->(real) : "pdiff_d" +PM__intrinsic lint(real)->(lint) : "offset_d" +PM__intrinsic cpx(real)->(cpx) : "complex_d" +PM__intrinsic _cpx2(real,real)->(cpx) : "complex2_d" +proc cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y)) + +// scpx type +PM__intrinsic PM__assign_var(&scpx,scpx): "assign_c" +PM__intrinsic +(scpx,scpx)->(scpx) : "add_c" +PM__intrinsic -(scpx,scpx)->(scpx) : "sub_c" +PM__intrinsic *(scpx,scpx)->(scpx) : "mult_c" +PM__intrinsic /(scpx,scpx)->(scpx) : "divide_c" +PM__intrinsic **(scpx,sreal)->(scpx) : "rpow_c" +PM__intrinsic **(scpx,scpx)->(scpx) : "pow_c" +PM__intrinsic -(scpx)->(scpx) : "uminus_c" +PM__intrinsic ==(scpx,scpx)->(bool) : "eq_c" +PM__intrinsic /=(scpx,scpx)->(bool) : "ne_c" +PM__intrinsic re(scpx)->(sreal) : "real_c" +PM__intrinsic abs(scpx)->(scpx) : "abs_c" +PM__intrinsic acos(scpx)->(scpx) : "acos_c" +PM__intrinsic asin(scpx)->(scpx) : "asin_c" +PM__intrinsic atan(scpx)->(scpx) : "atan_c" +PM__intrinsic atan2(scpx,scpx)->(scpx) : "atan2_c" +PM__intrinsic cos(scpx)->(scpx) : "cos_c" +PM__intrinsic cosh(scpx)->(scpx) : "cosh_c" +PM__intrinsic exp(scpx)->(scpx) : "exp_c" +PM__intrinsic log(scpx)->(scpx) : "log_c" +PM__intrinsic sin(scpx)->(scpx) : "sin_c" +PM__intrinsic sinh(scpx)->(scpx) : "sinh_c" +PM__intrinsic sqrt(scpx)->(scpx) : "sqrt_c" +PM__intrinsic tan(scpx)->(scpx) : "tan_c" +PM__intrinsic tanh(scpx)->(scpx) : "tanh_c" +PM__intrinsic im(scpx)->(sreal) : "imag_c" +PM__intrinsic conj(scpx)->(scpx) : "conj_c" + +// cpx type +PM__intrinsic PM__assign_var(&cpx,cpx): "assign_dc" +PM__intrinsic +(cpx,cpx)->(cpx) : "add_dc" +PM__intrinsic -(cpx,cpx)->(cpx) : "sub_dc" +PM__intrinsic *(cpx,cpx)->(cpx) : "mult_dc" +PM__intrinsic /(cpx,cpx)->(cpx) : "divide_dc" +PM__intrinsic **(cpx,real)->(cpx) : "dpow_dc" +proc **(x:cpx,y:sreal)=x**real(y) +PM__intrinsic **(cpx,cpx)->(cpx) : "pow_dc" +PM__intrinsic -(cpx)->(cpx) : "uminus_dc" +PM__intrinsic ==(cpx,cpx)->(bool) : "eq_dc" +PM__intrinsic /=(cpx,cpx)->(bool) : "ne_dc" +PM__intrinsic re(cpx)->(real) : "real_dc" +PM__intrinsic abs(cpx)->(cpx) : "abs_dc" +PM__intrinsic acos(cpx)->(cpx) : "acos_dc" +PM__intrinsic asin(cpx)->(cpx) : "asin_dc" +PM__intrinsic atan(cpx)->(cpx) : "atan_dc" +PM__intrinsic atan2(cpx,cpx)->(cpx) : "atan2_dc" +PM__intrinsic cos(cpx)->(cpx) : "cos_dc" +PM__intrinsic cosh(cpx)->(cpx) : "cosh_dc" +PM__intrinsic exp(cpx)->(cpx) : "exp_dc" +PM__intrinsic log(cpx)->(cpx) : "log_dc" +PM__intrinsic sin(cpx)->(cpx) : "sin_dc" +PM__intrinsic sinh(cpx)->(cpx) : "sinh_dc" +PM__intrinsic sqrt(cpx)->(cpx) : "sqrt_dc" +PM__intrinsic tan(cpx)->(cpx) : "tan_dc" +PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" +PM__intrinsic im(cpx)->(real) : "imag_dc" +PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + + +// Cannot convert real to int (must use nint or trunc) +proc sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => fix(false) +proc int(x:any_real)=0 :test "Cannot convert real to integer" => fix(false) +proc lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => fix(false) + +// Some numeric conversions not hard-coded +proc cpx(x:real_num)=cpx(real(x)) +proc scpx(x:real_num)=cpx(sreal(x)) +proc string(x:any_int)=string(int64(x)) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc int(x:fix(int))=x + +// Abstract numeric types +type any_int is sint,int,lint,int8,int16,int32,int64 +type any_real is sreal,real +type any_cpx is scpx,cpx +type int_num is any_int +type real_num is int_num, any_real +type cpx_num is real_num,any_cpx +type num is cpx_num + +// Numeric type conversion +proc convert(x,y)=x +proc convert(x:int_num,y:sint)=sint(x) +proc convert(x:int_num,y:int)=int(x) +proc convert(x:int_num,y:lint)=lint(x) +proc convert(x:int_num,y:int8)=int8(x) +proc convert(x:int_num,y:int16)=int16(x) +proc convert(x:int_num,y:int32)=int32(x) +proc convert(x:int_num,y:int64)=int64(x) +proc convert(x:int_num,y:sreal)=sreal(x) +proc convert(x:int_num,y:real)=real(x) +proc convert(x:real_num,y:cpx)=cpx(x) +proc convert(x:real_num,y:scpx)=scpx(x) +proc as(x:int_num,y:)=sint(x) +proc as(x:int_num,y:)=int(x) +proc as(x:int_num,y:)=lint(x) +proc as(x:int_num,y:)=int8(x) +proc as(x:int_num,y:)=int16(x) +proc as(x:int_num,y:)=int32(x) +proc as(x:int_num,y:)=int64(x) +proc as(x:real_num,y:)=sreal(x) +proc as(x:real_num,y:)=real(x) +proc as(x:real_num,y:)=scpx(x) +proc as(x:real_num,y:)=cpx(x) + +// Auto-conversion on assignment +proc PM__assign(&x:num,y:num) { + _assign_element(&x,convert(y,x)) +} + +proc PM__assign_var(&x:num,y:num) { + PM__assign(&x,convert(y,x)) +} + +// Mixed arithmatic +type _to_sint is int +type _to_lint is sint,int +type _to_int8 is sint,int,lint +type _to_int16 is sint,int,lint,int8 +type _to_int32 is sint,int,lint,int8,int16 +type _to_int64 is sint,int,lint,int8,int16,int32 +type _to_real is any_int +type _to_sreal is any_int,real +type _to_cpx is real_num +type _to_scpx is real_num,cpx +proc balance(x:sint,y:sint)=x,y +proc balance(x:int,y:int)=x,y +proc balance(x:lint,y:lint)=x,y +proc balance(x:int8,y:int8)=x,y +proc balance(x:int16,y:int16)=x,y +proc balance(x:int32,y:int32)=x,y +proc balance(x:int64,y:int64)=x,y +proc balance(x:sreal,y:sreal)=x,y +proc balance(x:real,y:real)=x,y +proc balance(x:scpx,y:scpx)=x,y +proc balance(x:cpx,y:cpx)=x,y +proc balance(x:sint,y:_to_sint)=x,sint(y) +proc balance(x:lint,y:_to_lint)=x,lint(y) +proc balance(x:int8,y:_to_int8)=x,int8(y) +proc balance(x:int16,y:_to_int16)=x,int16(y) +proc balance(x:int32,y:_to_int32)=x,int32(y) +proc balance(x:int64,y:_to_int64)=x,int64(y) +proc balance(x:sreal,y:_to_sreal)=x,sreal(y) +proc balance(x:real,y:_to_real)=x,real(y) +proc balance(x:scpx,y:_to_scpx)=x,scpx(y) +proc balance(x:cpx,y:_to_cpx)=x,cpx(y) +proc balance(x:_to_sint,y:sint)=sint(x),y +proc balance(x:_to_lint,y:lint)=lint(x),y +proc balance(x:_to_int8,y:int8)=int8(x),y +proc balance(x:_to_int16,y:int16)=int16(x),y +proc balance(x:_to_int32,y:int32)=int32(x),y +proc balance(x:_to_int64,y:int64)=int64(x),y +proc balance(x:_to_sreal,y:sreal)=sreal(x),y +proc balance(x:_to_real,y:real)=real(x),y +proc balance(x:_to_scpx,y:scpx)=scpx(x),y +proc balance(x:_to_cpx,y:cpx)=cpx(x),y +proc div(x:any_int,y:any_int)=if(sz=>r,-1-r) where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))where sz=sign(x,y)==x +proc _divz(x:any_int,y:any_int)=z { + var z,_=balance(x,y) + if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y) +} +proc mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y) +proc ==(x:num,y:num)=xx==yy where xx,yy=balance(x,y) +proc /=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y) +proc >=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y) +proc >(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y) +proc +(x:num,y:num)=xx+yy where xx,yy=balance(x,y) +proc -(x:num,y:num)=xx-yy where xx,yy=balance(x,y) +proc *(x:num,y:num)=xx*yy where xx,yy=balance(x,y) +proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) +proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) +proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) +proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) +proc xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y) +proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) +proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) +proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) + +// bool type +PM__intrinsic PM__assign_var(&bool,bool): "assign_l" +PM__intrinsic string(bool)->(string) : "string_l" +PM__intrinsic and(bool,bool)->(bool) : "and" +PM__intrinsic or(bool,bool)->(bool) : "or" +PM__intrinsic not(bool)->(bool) : "not" +PM__intrinsic ==(bool,bool)->(bool) : "eq_l" +PM__intrinsic /=(bool,bool)->(bool) : "ne_l" + +/* + +// Masked types +type masked(x) is rec {_val:x,_there:bool} +proc |(x:masked,y)=if(x._there=>x._val,y) + check "Right operand of ""|"" does not match masked type on the left"=>same_type(x._val,y) + +proc masked(val,there:bool)=new masked { + _val=val,_there=there +} + +proc defined(x:masked)=x._there +proc val(x:masked)=x._val check "masked value is undefined"=>x._there + +proc get(&x,y:masked) { + if y._there{ + x=y._val + } +} + +proc get(&x,y:masked(x)) { + if y._there{ + x=y._val + } + return y._there +} + +// Polymorphic types +PM__intrinsic get(x:*any,y:any)->(=y) : "as" +PM__intrinsic<> get(&x:any,y:*any): "get_poly" +PM__intrinsic<> get(&x:any,y:*any)->(bool) : "get_poly2" +PM__intrinsic<> |(x:*any,y:any)->(=y) : "get_poly_or" + +// val function having null effect +proc val(x)=x + +// ******************************************** +// TUPLES +// ******************************************** + +// Tuple types +type tuple1d(t1) is rec {PM__d1:t1} +type tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2} +type tuple3d(t1,t2,t3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3} +type tuple4d(t1,t2,t3,t4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4} +type tuple5d(t1,t2,t3,t4,t5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5} +type tuple6d(t1,t2,t3,t4,t5,t6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6} +type tuple7d(t1,t2,t3,t4,t5,t6,t7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7} +type tuple1d_of(t) is tuple1d(t) +type tuple2d_of(t) is tuple2d(t,t) +type tuple3d_of(t) is tuple3d(t,t,t) +type tuple4d_of(t) is tuple4d(t,t,t,t) +type tuple5d_of(t) is tuple5d(t,t,t,t,t) +type tuple6d_of(t) is tuple6d(t,t,t,t,t,t) +type tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t) +type tuple(t) is tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),tuple5d(t,t,t,t,t), + tuple6d(t,t,t,t,t,t),tuple7d(t,t,t,t,t,t,t) + +proc tuple(x)=new tuple1d { + PM__d1=x +} +proc tuple(x,y)=new tuple2d { + PM__d1=x,PM__d2=y +} +proc tuple(x,y,z)=new tuple3d { + PM__d1=x,PM__d2=y,PM__d3=z +} +proc tuple(x,y,z,t)=new tuple4d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t +} +proc tuple(x,y,z,t,u)=new tuple5d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u +} +proc tuple(x,y,z,t,u,v)=new tuple6d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v +} +proc tuple(x,y,z,t,u,v,w)=new tuple7d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w +} + +proc get_dim(t:tuple1d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple2d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple3d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple4d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple5d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple6d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple7d,n:fix(1) or [fix(1)])=t.1 +proc get_dim(t:tuple2d,n:fix(2) or [fix(2)])=t.2 +proc get_dim(t:tuple3d,n:fix(2) or [fix(2)])=t.2 +proc get_dim(t:tuple4d,n:fix(2) or [fix(2)])=t.2 +proc get_dim(t:tuple5d,n:fix(2) or [fix(2)])=t.2 +proc get_dim(t:tuple6d,n:fix(2) or [fix(2)])=t.2 +proc get_dim(t:tuple7d,n:fix(2) or [fix(2)])=t.2 +proc get_dim(t:tuple3d,n:fix(3) or [fix(3)])=t.3 +proc get_dim(t:tuple4d,n:fix(3) or [fix(3)])=t.3 +proc get_dim(t:tuple5d,n:fix(3) or [fix(3)])=t.3 +proc get_dim(t:tuple6d,n:fix(3) or [fix(3)])=t.3 +proc get_dim(t:tuple7d,n:fix(3) or [fix(3)])=t.3 +proc get_dim(t:tuple4d,n:fix(4) or [fix(4)])=t.4 +proc get_dim(t:tuple5d,n:fix(4) or [fix(4)])=t.4 +proc get_dim(t:tuple6d,n:fix(4) or [fix(4)])=t.4 +proc get_dim(t:tuple7d,n:fix(4) or [fix(4)])=t.4 +proc get_dim(t:tuple5d,n:fix(5) or [fix(5)])=t.5 +proc get_dim(t:tuple6d,n:fix(5) or [fix(5)])=t.5 +proc get_dim(t:tuple7d,n:fix(5) or [fix(5)])=t.5 +proc get_dim(t:tuple6d,n:fix(6) or [fix(6)])=t.6 +proc get_dim(t:tuple7d,n:fix(6) or [fix(6)])=t.6 +proc get_dim(t:tuple7d,n:fix(7) or [fix(7)])=t.7 + +proc indices(x:tuple1d)=[fix(1)] +proc indices(x:tuple2d)=[fix(1),fix(2)] +proc indices(x:tuple3d)=[fix(1),fix(2),fix(3)] +proc indices(x:tuple4d)=[fix(1),fix(2),fix(3),fix(4)] +proc indices(x:tuple5d)=[fix(1),fix(2),fix(3),fix(4),fix(5)] +proc indices(x:tuple6d)=[fix(1),fix(2),fix(3),fix(4),fix(5),fix(6)] +proc indices(x:tuple7d)=[fix(1),fix(2),fix(3),fix(4),fix(5),fix(6),fix(7)] + +proc full_rank(x:tuple1d)=1 +proc full_rank(x:tuple2d)=2 +proc full_rank(x:tuple3d)=3 +proc full_rank(x:tuple4d)=4 +proc full_rank(x:tuple5d)=5 +proc full_rank(x:tuple6d)=6 +proc full_rank(x:tuple7d)=7 +proc rank(x:tuple)=full_rank(x) + +proc reduce(p:proc,x:tuple1d)=x.1 +proc reduce(p:proc,x:tuple2d)=p.(x.2,x.1) +proc reduce(p:proc,x:tuple3d)=p.(p.(x.3,x.2),x.1) +proc reduce(p:proc,x:tuple4d)=p.(p.(p.(x.4,x.3),x.2),x.1) +proc reduce(p:proc,x:tuple5d)=p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple6d)=p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1) + +proc map(p:proc,x:tuple1d)=[p.(x.1)] +proc map(p:proc,x:tuple2d)=[p.(x.1),p.(x.2)] +proc map(p:proc,x:tuple3d)=[p.(x.1),p.(x.2),p.(x.3)] +proc map(p:proc,x:tuple4d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4)] +proc map(p:proc,x:tuple5d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)] +proc map(p:proc,x:tuple6d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)] +proc map(p:proc,x:tuple7d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)] +proc map(p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map(p:proc,x:tuple1d,y:tuple1d)=[p.(x.1,y.1)] +proc map(p:proc,x:tuple2d,y:tuple2d)=[p.(x.1,y.1),p.(x.2,y.2)] +proc map(p:proc,x:tuple3d,y:tuple3d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)] +proc map(p:proc,x:tuple4d,y:tuple4d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4)] +proc map(p:proc,x:tuple5d,y:tuple5d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5)] +proc map(p:proc,x:tuple6d,y:tuple6d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)] +proc map(p:proc,x:tuple7d,y:tuple7d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)] +proc map(p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(x.1,y.1,z.1)] +proc map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)] +proc map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)] +proc map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4)] +proc map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)] +proc map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)] +proc map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),p.(x.7,y.7,z.7)] + +proc map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(w.1,x.1,y.1,z.1)] +proc map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)] +proc map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)] +proc map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4)] +proc map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)] +proc map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)] +proc map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),p.(w.7,x.7,y.7,z.7)] + +proc map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]where u1,v1=p.(x.1,y.1) +proc map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2) +proc map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3) +proc map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4) +proc map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5) +proc map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6) +proc map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7) + +proc map_const(p:proc,x:tuple1d,y)=[p.(x.1,y)] +proc map_const(p:proc,x:tuple2d,y)=[p.(x.1,y),p.(x.2,y)] +proc map_const(p:proc,x:tuple3d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y)] +proc map_const(p:proc,x:tuple4d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y)] +proc map_const(p:proc,x:tuple5d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y)] +proc map_const(p:proc,x:tuple6d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y)] +proc map_const(p:proc,x:tuple7d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)] + +proc map_reduce(q:proc,p:proc,x:tuple1d)=q.(x.1) +proc map_reduce(q:proc,p:proc,x:tuple2d)=p.(q.(x.2),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d)=p.(p.(q.(x.3),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d)=p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d)=p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d)=p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)=q.(x.1,y.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.2,y.2),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(p.(q.(x.3,y.3),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=q.(x.1,y.1,z.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) + +proc apply(p:proc,x:tuple1d)=p.(x.1) +proc apply(p:proc,x:tuple2d)=p.(x.1,x.2) +proc apply(p:proc,x:tuple3d)=p.(x.1,x.2,x.3) +proc apply(p:proc,x:tuple4d)=p.(x.1,x.2,x.3,x.4) +proc apply(p:proc,x:tuple5d)=p.(x.1,x.2,x.3,x.4,x.5) +proc apply(p:proc,x:tuple6d)=p.(x.1,x.2,x.3,x.4,x.5,x.6) +proc apply(p:proc,x:tuple7d)=p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7) + +proc map_apply(q:proc,p:proc,x:tuple1d)=p.(q.(x.1)) +proc map_apply(q:proc,p:proc,x:tuple2d)=p.(q.(x.1),q.(x.2)) +proc map_apply(q:proc,p:proc,x:tuple3d)=p.(q.(x.1),q.(x.2),q.(x.3)) +proc map_apply(q:proc,p:proc,x:tuple4d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4)) +proc map_apply(q:proc,p:proc,x:tuple5d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5)) +proc map_apply(q:proc,p:proc,x:tuple6d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6)) +proc map_apply(q:proc,p:proc,x:tuple7d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6),q.(x.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type():test "Number of dimensions does not match" => fix(false) +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)=p.(q.(x.1,y.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.1,y.1),q.(x.2,y.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=p.(q.(x.1,y.1,z.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7)) + +proc scan(p:proc,x:tuple1d)=x.1 +proc scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)] +proc scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)] where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +proc pre_scan(p:proc,x:tuple1d,x0)=x0 +proc pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1] +proc pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)] +proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +type empty_head is unique + +proc head(x:null)=empty_head +proc head(x:tuple)=x.1 + +proc tail(x:null)=null +proc tail(x:tuple1d)=null +proc tail(x:tuple2d)=[x.2] +proc tail(x:tuple3d)=[x.2,x.3] +proc tail(x:tuple4d)=[x.2,x.3,x.4] +proc tail(x:tuple5d)=[x.2,x.3,x.4,x.5] +proc tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6] +proc tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7] + +proc prepend(y,x:null)=[y] +proc prepend(y,x:tuple1d)=[y,x.1] +proc prepend(y,x:tuple2d)=[y,x.1,x.2] +proc prepend(y,x:tuple3d)=[y,x.1,x.2,x.3] +proc prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4] +proc prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5] +proc prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6] +proc prepend(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => fix(false) + +proc append(x:null,y)=[y] +proc append(x:tuple1d,y)=[x.1,y] +proc append(x:tuple2d,y)=[x.1,x.2,y] +proc append(x:tuple3d,y)=[x.1,x.2,x.3,y] +proc append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y] +proc append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y] +proc append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y] +proc append(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => fix(false) + +proc elems(x:tuple1d)=x.1 +proc elems(x:tuple2d)=x.1,x.2 +proc elems(x:tuple3d)=x.1,x.2,x,3 +proc elems(x:tuple4d)=x.1,x.2,x.3,x.4 +proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 +proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 +proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 + +proc replace(x:tuple1d,y:fix(1),z)=[z] +proc replace(x:tuple2d,y:fix(1),z)=[z,x.2] +proc replace(x:tuple3d,y:fix(1),z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:fix(1),z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:fix(1),z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:fix(1),z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:fix(1),z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:fix(2),z)=[x.1,z] +proc replace(x:tuple3d,y:fix(2),z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:fix(2),z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:fix(2),z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:fix(2),z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:fix(2),z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:fix(3),z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:fix(3),z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:fix(3),z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:fix(3),z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:fix(3),z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:fix(4),z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:fix(4),z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:fix(4),z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:fix(4),z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:fix(5),z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:fix(5),z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:fix(5),z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:fix(6),z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:fix(6),z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:fix(7),z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or fix(1))=[x] +proc spread(x,y:tuple2d or fix(2))=[x,x] +proc spread(x,y:tuple3d or fix(3))=[x,x,x] +proc spread(x,y:tuple4d or fix(4))=[x,x,x,x] +proc spread(x,y:tuple5d or fix(5))=[x,x,x,x,x] +proc spread(x,y:tuple6d or fix(6))=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or fix(7))=[x,x,x,x,x,x,x] + +proc +(x:tuple(num),y:tuple(num))=map($+,x,y) +proc -(x:tuple(num),y:tuple(num))=map($-,x,y) +proc *(x:tuple(num),y:tuple(num))=map($*,x,y) +proc /(x:tuple(num),y:tuple(num))=map($/,x,y) +proc **(x:tuple(num),y:tuple(num))=map($**,x,y) +proc mod(x:tuple(num),y:tuple(num))=map($mod,x,y) +proc +(x:tuple(num),y:num)=map_const($+,x,y) +proc -(x:tuple(num),y:num)=map_const($-,x,y) +proc *(x:tuple(num),y:num)=map_const($*,x,y) +proc /(x:tuple(num),y:num)=map_const($/,x,y) +proc **(x:tuple(num),y:num)=map_const($**,x,y) +proc mod(x:tuple(num),y:num)=map_const($mod,x,y) +proc max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y) +proc min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y) +proc max(x:tuple(real_num))=reduce($max,x) +proc min(x:tuple(real_num))=reduce($min,x) +proc sum(x:tuple(num))=reduce($+,x) +proc prod(x:tuple(num))=reduce($*,x) +proc sint(x:tuple(num))=map($sint,x) +proc int(x:tuple(num))=map($int,x) +proc sreal(x:tuple(num))=map($sreal,x) +proc real(x:tuple(num))=map($real,x) + +proc string(x:tuple1d)="[ "++x.1++" ]" +proc string(x:tuple2d)="[ "++x.1++", "++x.2++" ]" +proc string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]" +proc string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]" +proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]" +proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" +proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + +// ***************************************************** +// LISTS +// ***************************************************** + +type _list_node(H,T) is struct{_head:H,_tail:T} +type list(T) is _list_node(T,T or _list_node(T,list(T))) +type _list_end is unique + +proc _cons(a,b)=new _list_node{_head=a,_tail=b} + +proc list(a)<>=_cons(a,_list_end) +proc list(a,arg...)<>=_cons(a,list(arg...)) + +proc reduce(p,a:_list_node)=p.(a._head,reduce(p,a._tail)) +proc reduce(p,a:_list_node(,_list_end))=a._head + +proc map(p,&a:_list_node){p.(a._head);map(p,a._tail)} +proc map(p,&a:_list_node(,_list_end)):p.(a._head) + +proc map(p,&a:_list_node(,_list_node),b:_list_node(,_list_node)){p.(&a._head,b._head);map(p,&a._tail,b._tail)} +proc map(p,&a:_list_node(,_list_end),b:_list_node(,_list_end)):p.(&a._head,b._head) +proc map(p,&a:_list_node,b:_list_node): test "List lengths do not match"=>fix(false) + +proc map_const(p,&a:_list_node(,_list_node),b){p.(&a._head,b);map_const(p,&a._tail,b)} +proc map_const(p,&a:_list_node(,_list_end),b):p.(&a._head,b) + +proc PM__assign(&a:list,b:list):map($PM__assign,&a,b) +proc PM__assign(&a:list,b):map_const($PM__assign,&a,b) + +proc map(p,a:_list_node)=_cons(p.(a._head),map(p,a._tail)) +proc map(p,a:_list_node(,_list_end))=_cons(p.(a._head),_list_end) + +proc map(p,a:_list_node(,_list_node),b:_list_node(,_list_node))=_cons(p.(a._head,b._head),map(p,a._tail,b._tail)) +proc map(p,a:_list_node(,_list_end),b:_list_node(,_list_end))=_cons(p.(a._head,b._head),_list_end) +proc map(p,a:_list_node,b:_list_node)=_cons(p.(a._head,b._head),_list_end) check "List lengths do not match"=>fix(false) + +proc [](a:list,b:fix(int))=_list_elem(a,b,1) +proc _list_elem(a:_list_node(,_list_node),b:fix(int),c:fix(int)) { + const d + if fix(b==c) { + d=a._head + } else { + d=_list_elem(a,b,c+1) + } + return d +} +proc _list_elem(a:_list_node(,_list_end),b:fix(int),c:fix(int)) { + test "List element out of range"=>a==b + return a._head +} + +// ***************************************************** +// RANGES AND SEQUENCES +// ***************************************************** + +// Not in operator +proc notin(x,y)=not(x in y) + +// not inc operator +proc notinc(x,y)=not(x inc y) + +// Treat null as empty sequence in some cases +proc in(x,y:null)=fix(false) +proc in(x:null,y:null)=fix(true) + +// Range base type (might later expand to interface) +type range_base is real_num + +// Single point sequence +type single_point(t:range_base) is rec {_t:t} +proc single_point(x)=new single_point { + _t=x +} +proc low(x:single_point)=x._t +proc high(x:single_point)=x._t +proc step(x:single_point)=x._t +proc width(x:single_point)=fix(1) +proc norm(x:single_point)=x +proc #(x:single_point)=shape([fix(0)..fix(0)]) +proc _shp(x:single_point)=fix(0)..fix(0) +proc dims(x:single_point)=[fix(1)] +proc size(x:single_point)=fix(1) +proc +(x:single_point,y:range_base)=new single_point { + _t=x._t+y +} +proc -(x:single_point,y:range_base)=new single_point { + _t=x._t-y +} +proc _arb(x:single_point)=x._t +proc in(x:range_base,y:single_point)=x==y._t +proc inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t +proc convert(x:single_point,y:range_base)=single_point(convert(x._t,y)) +proc sint(x:single_point)=single_point(sint(x._t)) +proc int(x:single_point)=single_point(int(x._t)) +proc sreal(x:single_point)=single_point(sreal(x._t)) +proc real(x:single_point)=single_point(real(x._t)) +proc #(x:single_point,y:index)=fix(0) +proc #(x:single_point,y:grid_slice_dim)=fix(0)..fix(0) +proc #(x:single_point,y:single_point)=fix(0)..fix(0) +proc #(x:grid_slice_dim,y:single_point)=single_point(xx) where xx=x#y._t +proc overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1) +proc overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1) +proc overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1) +proc overlap(x:single_point(any_int),y:single_point(any_int))=overlap(x,y),overlap(y,x) +proc overlap(x:grid_slice_dim,y:single_point(any_int))=overlap(x,y),overlap(y,x) +proc overlap(x:single_point(any_int),y:grid_slice_dim)=overlap(x,y),overlap(y,x) +proc intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1) +proc intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1) +proc intersect(x:single_point(any_int),y:single_point(any_int))=x._t..if(x._t==y._t=>x._t,x._t-1) +proc element(x:single_point,y:index)=x._t +proc element(x:single_point,y:subs)=x._t..x._t +proc element(x,y:single_point)=element(x,y._t) +proc string(x:single_point)=string("single "++x._t) + +// Range types +type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} +proc ..(x:range_base,y:range_base)=new range { +_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:range)=x._lo +proc high(x:range)=x._hi +proc step(x:range)=convert(1,x._lo) +proc width(x:range)=fix(1) +proc norm(x:range)=x +proc #(x:range(int))=shape([0..x._n-1]) +proc dims(x:range(int))=[x._n] +proc size(x:range(int))=x._n +proc +(x:range,y:range_base)=new range { + _lo=x._lo+y,_hi=x._hi+y,_n=x._n +} +proc -(x:range,y:range_base)=new range { + _lo=x._lo-y,_hi=x._hi-y,_n=x._n +} +proc _arb(x:range)=low(x) +proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi +proc convert(x:range,y:range_base)=new range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n +} +proc sint(x:range)=new range { + _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n +} +proc int(x:range)=new range { + _lo=int(x._lo),_hi=int(x._hi),_n=x._n +} +proc sreal(x:range)=new range { + _lo=sreal(x._lo),_hi=sreal(x._hi) +} +proc real(x:range)=new range { + _lo=real(x._lo),_hi=real(x._hi),_n=x._n +} +proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi +proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) +proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st +proc element(x:range(any_int),y:null)=x +proc element(x:range(any_int),y:grid_dim)=y+x._lo +proc #(y:range(any_int),x:int)=int(x-y._lo) +proc #(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #(y:range(any_int),x:strided_range_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #(y:range(any_int),x:strided_range_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #(y:range(any_int),x:stride(int))=_intseq(0,size(y),int(x._st)) +proc #(y:range(any_int),x:null)=0..size(y) +proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) +proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo +proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi +proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi +proc empty(x:range)=new range { + _lo=x._hi,_hi=x._lo,_n=0 +} +proc string(x:range)=string(x._lo)++".."++(x._hi) +// Cyclic range types (limited functionality and not part of grid) +type cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int} +proc cyclic_range(x:int,y:int,w:int)=new cyclic_range { +_lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:cyclic_range)=x._lo +proc high(x:cyclic_range)=x._hi +proc size(x:cyclic_range)=x._n +proc element(x:cyclic_range,y:int)=(x._lo + y) mod x._w +proc string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")" +// Strided range types +type strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int} +type _any_seq(t:range_base):iterable is strided_range(t), ... +type _any_seq(t:any_int) is ..., range(t) +type seq(t:range_base) is _any_seq(t) +proc _seq(lo,hi,st)=new strided_range { +_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) +proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) +proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y +proc _intseq(x:int,y:int,st:int)= new strided_range { +_lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) +proc low(x:strided_range)=x._lo +proc high(x:strided_range)=x._hi +proc step(x:strided_range)=x._st +proc size(x:strided_range)=x._n +proc width(x:strided_range)=fix(1) +proc norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)=fix(0) +proc #(x:strided_range)=shape([0..x._n-1]) +proc dims(x:strided_range)=[x._n] +proc +(x:strided_range,y:range_base)=new strided_range { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n +} +proc -(x:strided_range,y:range_base)=new strided_range { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n +} +proc _arb(x:seq)=x._lo +proc convert(x:strided_range,y:range_base)=new strided_range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n +} +proc sint(x:strided_range)=new strided_range { + _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n +} +proc int(x:strided_range)=new strided_range { + _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n +} +proc sreal(x:strided_range)=new strided_range { + _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n +} +proc real(x:strided_range)=new strided_range { + _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n +} +proc in(x:int,y:strided_range(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:strided_range(int),y:strided_range(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:strided_range(int),y:range(int) or single_point(int))=x inc low(y)..high(y) by 1 +proc #(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #(y:seq,x:range)=y#x._lo..y#x._hi +proc #(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #(y:seq,x:range_below)=0..y#x._t +proc #(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #(y:seq,x:strided_range_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:strided_range_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:stride)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:null)=0..size(y)-1 +proc string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st +proc element(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:strided_range,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:strided_range,y:strided_range(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:strided_range,y:null)=x +proc overlap(x:strided_range(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:strided_range(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:strided_range(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x) +PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" +proc intersect(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +_lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc overlap(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc empty(x:strided_range(any_int))=new strided_range { + _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 +} +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=new block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #(x:block_seq)=shape([0..x._n-1]) +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=new block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=new block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:grid_dim){ + var a=array(0,#x) + forall i in a,j in x:i=j + return new map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=new map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +} +proc map_seq(x:map_seq)=x +proc #(x:map_seq)=#(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=new map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=new map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=new map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=new map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=new map_seq { + array=a[ns] + } + w=new map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=new map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return new map_seq { + array=a + } +} +// Grids (tuples of sequences) +type _grid_dim(t:range_base) is seq(t),... +type _grid_dim(t:int) is ...,block_seq,map_seq +type grid_dim(t:range_base) is _grid_dim(t) +type grid1d(t1:grid_dim) is [t1] +type grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2] +type grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is [t1,t2,t3] +type grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is [t1,t2,t3,t4] +type grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim) is [t1,t2,t3,t4,t5] +type grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim) is [t1,t2,t3,t4,t5,t6] +type grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim,t7:grid_dim) is [t1,t2,t3,t4,t5,t6,t7] +type grid(t:range_base) is tuple(grid_dim(t)) +proc #(x:grid)=shape(map($_shp,x)) +proc dims(x:grid)=map($_size,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($+,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:grid_dim,y:grid_dim){ + var a=array(0,#y) + forall i in a,j in y:i=x[j] + return new map_seq{ + array=a + } +} +proc element(x:grid,y:grid)=map($element,x,y) +// Slices of grids (may have dims that are just an integer and also _ or _() or null) +type grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null +type grid_slice(t) is grid(t),tuple(grid_slice_dim(t)) +// Some limited functionality for extended grids (which include cyclic ranges) +type iterable_dim is grid_slice_dim,cyclic_range,... +type iterable_grid is tuple(iterable_dim),grid_slice +proc _shp(x:iterable_dim)=0..size(x)-1 +proc size(x:iterable_dim)->(int)... +proc element(x:iterable_dim,y)=error_type()check "Cannot index this type with a non-integer index"=>fix(false) +proc element(x:iterable_dim,y:int)->(any)... +proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) +proc _shp(x:stretch_dim)=null +proc _shp(x:null)=x +proc _size(x:stretch_dim or null)=fix(1) +proc _size(x)=size(x) +PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" +proc _act(x)=x +proc _sliceit(arg...)=tuple(arg...) +proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) +proc active_dims(x:single_point)=null +PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _act(x,y)=y +proc active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y) +proc active_dims(x:single_point,y)=null +proc _ar(x:single_point)=0 +proc _ar(x)=1 +proc rank(x:iterable_grid)=map_reduce($_ar,$+,x) +proc element(x:iterable_grid,y:index){ + t=_tup(y) + return _ges(head(x),tail(x),head(t),tail(t),fix(false)) +} +proc element(x:grid_slice,arg...:grid_slice){ + t=_tup(arg...) + return _ges(head(x),tail(x),head(t),tail(t),fix(true)) +} + +proc element(x:null,y)=null +proc _spnt(i,y:fix(true))=i +proc _spnt(i,y:fix(false))=i._t +proc _spif(i:int,y:fix(true))=single_point(i) +proc _spif(i,y:fix(true))=i +proc _spif(i,y:fix(false))=i +proc _ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => fix(false) +proc _ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:fix(true))=prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:fix(false))=_ges(head(x),tail(x),head(y),tail(y),t) +proc _ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t) +proc _ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j:empty_head,y,t)=null +proc _ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => fix(false) +proc _ges(i:null,x,j:empty_head,y,t:fix(true))=error_type() :test "Rank mismatch" => fix(false) +proc _ges(i:null,x,j:empty_head,y,t:fix(false))=null +proc size(x:iterable_grid)=map_reduce($_size,$*,x) +proc #(x:grid_slice)=shape(map($_shp,active_dims(x))) +proc dims(x:iterable_grid)=map($_size,active_dims(x)) +proc _arb(x:grid_slice)=map($_arb,x) +proc in(x:tuple(range_base),y:grid_slice)=map_reduce($in,$and,x,y) +proc inc(x:grid_slice,y:grid_slice)=map_reduce($inc,$and,x,y) +proc #(x:grid,y:tuple(subs_dim))=map($#,x,y) +PM__intrinsic _acthash(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _acthash(x,y)=x#y +proc #(x:grid_slice,y:tuple(subs_dim) or grid_slice)=map_apply($_acthash,$_sliceit,x,y) +proc convert(x:grid_slice,y:real_num)=map_const($convert,x,y) +proc sint(x:grid_slice)=map($sint,x) +proc int(x:grid_slice)=map($int,x) +proc sreal(x:grid_slice)=map($sreal,x) +proc real(x:grid_slice)=map($real,x) +proc low(x:grid_slice)=map($low,x) +proc high(x:grid_slice)=map($high,x) +proc overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y) +proc overlap(x:grid_slice,y:grid_slice)=u,v where u,v=map($overlap,x,y) +proc intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y) +proc intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y)) +proc expand(x:grid_slice,y:grid)=map($expand,x,y) +proc contact(x:grid_slice,y:grid)=map($contract,x,y) +PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" +// ***************************************************** +// SHAPES +// ***************************************************** +type extent is tuple(range(int) ),extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d +type extent1d is tuple1d_of(range(int)) +type extent2d is tuple2d_of(range(int)) +type extent3d is tuple3d_of(range(int)) +type extent4d is tuple4d_of(range(int)) +type extent5d is tuple5d_of(range(int)) +type extent6d is tuple6d_of(range(int)) +type extent7d is tuple7d_of(range(int)) +type mshape(extent_t:extent) is rec {use _extent:extent_t,_n:int,_o:int} +type mshape1d is mshape(extent1d) +type mshape2d is mshape(extent2d) +type mshape3d is mshape(extent3d) +type mshape4d is mshape(extent4d) +type mshape5d is mshape(extent5d) +type mshape6d is mshape(extent6d) +type mshape7d is mshape(extent7d) +// Create array, vector and matrix shapes +proc _low(x)=low(x) +proc _low(x:null)=fix(0) +proc _off(x)=-index(dims(x),map($_low,x)) +proc PM__array(arg...)=shape(map($_extnt,[arg...])) +proc _extnt(n:any_int)=0..int(n)-1 +proc _extnt(n:null)=null +proc _extnt(n:range(any_int))=int(n) +proc shape(extent:extent)=new mshape { + _extent=extent,_n=size(extent),_o=_off(extent) +} +// Conforming mshapes +proc check_conform(x,y) { + check_conform(#x,#y) +} +proc check_conform(x:mshape,y:mshape) { + test "Mshapes "++x++" and "++y++" do not conform"=>conform(x,y) +} + +proc _conform(x,y)=size(x)==size(y) +proc _conform(x:null,y)=size(y)==fix(1) +proc _conform(x,y:null)=fix(true) +proc _conform(x:null,y:null)=fix(true) +proc conform(x:mshape,y:mshape)=map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0check "Values of different ranks cannot conform"=>rank(x)==rank(y) +// Local size of a mshape +proc _local_size(x:mshape)=size(x._extent) +// Convert an extent to have a zero base +proc zero_base(x:range)=0..size(x)-1 +proc zero_base(x:extent)=map($zero_base,x) +// Extent of a mshape +proc extent(x:shape)=x._extent +// Dimensions of a mshape +proc dims(x:mshape)=map($size,x._extent) +// Size from dimensions +proc size(x:tuple(int))=reduce($*,x) +// Empty mshape +proc _empty(x)=1..0 +proc empty(x:extent)=map($_empty,x) +// Slice of mshape +proc [](x:mshape,s:index)=x._extent[s] +proc [](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,fix(true)))):check_contains(x,s) +// ***************************************************** +// INDEXING AND SLICING +// ***************************************************** +// Generic types supporting indexing and mapping +type iterable is iterable_grid,grid_slice,grid,grid_slice_dim,cyclic_range,array,... +proc [](x:iterable,arg...){ + d=#x + y=_tup(arg...) + check_contains(d,y) + return element(x,fill_in(d,y,fix(false))) +} +// Index type +type index is any_int,tuple(any_int) +// Slice and subscript types +type range_below(x) is rec {_t:x} +type range_above(x) is rec {_t:x} +type strided_range_below(x) is rec {_t:x,_st:x} +type strided_range_above(x) is rec {_t:x,_st:x} +type stride(x) is rec {_st:x} +type slice_dim is range(any_int),strided_range(any_int),range_above(any_int), range_below(any_int),strided_range_above(any_int),strided_range_below(any_int), stride(any_int),null,stretch_dim +type slice is slice_dim,tuple(slice_dim) +type subs_dim is slice_dim,any_int +type subs is index,slice,subs_dim,tuple(subs_dim) +// Partial ranges/sequences mainly used in subscripts +proc ..._(x)=new range_below { + _t=x +} +proc _...(x)=new range_above { + _t=x +} +proc by(x:range_base)=new stride { + _st=x +} +proc by(x:range_above(),y)=new strided_range_above { + _t=x._t,_st=convert(y,x._t) +} +proc by(x:range_below(),y)=new strided_range_below { + _t=x._t,_st=convert(y,x._t) +} +proc string(x:range_above)=x._t++"..." +proc string(x:range_below)="..."++x._t +proc string(x:strided_range_above)=x._t++"... by"++x._st +proc string(x:strided_range_below)="..."++x._t++"by "++x._st +proc string(x:stride)="by "++x._st +proc low(x:range_above)=x._t +proc low(x:strided_range_above)=x._t +proc high(x:range_below)=x._t +proc high(x:strided_range_below)=x._t +proc step(x:range_above or range_below)=fix(1) +proc step(x:strided_range_above or strided_range_below)=x._st +proc width(x:strided_range_above or strided_range_below or range_above or range_below)=fix(1) +// Stretch dimension in subscript +type stretch_dim is unique{PM__strdim} +proc string(x:stretch_dim)="_" +proc size(x:stretch_dim)=fix(1) +proc expand(x:stretch_dim,y:grid)=x +proc contract(x:stretch_dim,y:grid)=x +proc in(x:stretch_dim,y)=fix(true) +proc inc(x:stretch_dim,y)=fix(true) +proc convert(x:stretch_dim,y:range_base)=x +proc #(x:stretch_dim,y:index)=fix(0) +proc #(x:stretch_dim,y:grid_slice_dim)=fix(0)..fix(0) +proc intersect(x:stretch_dim,y:grid_slice_dim)=y +proc intersect(x:grid_slice_dim,y:stretch_dim)=x +proc intersect(x:stretch_dim,y:stretch_dim)=x +proc overlap(x:grid_slice_dim,y:stretch_dim)=#x +proc overlap(x:stretch_dim,y:grid_slice_dim)=fix(0)..fix(0) +proc overlap(x:stretch_dim,y:stretch_dim)=fix(0)..fix(0) +// Check subscript is in range +proc check_contains(a:extent,arg...) { + test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...) +} +proc check_contains(a:mshape,arg...) { + check_contains(a._extent,arg...) +} +proc check_contains(a,arg...) { + check_contains(#a,arg...) +} +proc check_contains(a:dshape,arg...) { + check_contains(a._mshape._extent,arg...) +} +proc _contains(x:null,y)=fix(true) +proc _contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y) +proc _contains(x:range(int),y:range(any_int) or seq(any_int))=_contains(x,y._lo) and _contains(x,y._hi) or y._lo>y._hi +proc _contains(x:range(int),y:range_below(any_int) or strided_range_below(any_int) or range_above(any_int) or strided_range_above(any_int))=_contains(x,y._t) +proc _contains(x:range(int),y:stride(any_int))=fix(true) +proc _contains(x:range(int),y:null)=fix(true) +proc contains(x:mshape1d,y:subs_dim)=_contains(x.1,y) +proc contains(x:extent,y:tuple(subs_dim))=map_reduce($_contains,$and,x,y) +PM__intrinsic _rgd(x:stretch_dim)->(PM__tinyint) : "miss_arg" +proc _rgd(x)=x +proc _rigid_dims(x:grid_slice or tuple(subs_dim))=map_apply($_rgd,$_sliceit,x) +proc contains(x:extent,y:tuple(subs_dim) and contains(stretch_dim))=contains(x,_rigid_dims(y)) +proc contains(x:extent,y,arg...)=contains(x,[y,arg...]) +// Complete a subscript using a base mshape +proc fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => fix(false) +proc fill_in(x:seq(int) or null,y:any_int,t:fix(true))=single_point(int(y)) +proc fill_in(x:seq(int) or null,y:any_int,t:fix(false))=int(y) +proc fill_in(x:seq(int) or null,y:any_int,t:null)=int(y)..int(y) +proc fill_in(x:seq(int) or null,y:range(any_int),t)=int(y) +proc fill_in(x:seq(int) or null,y:strided_range(any_int),t)=int(y) +proc fill_in(x:seq(int),y:range_below(any_int),t)=x._lo..int(y._t) +proc fill_in(x:seq(int),y:range_above(any_int),t)=int(y._t)..x._hi +proc fill_in(x:seq(int),y:strided_range_below(any_int),t)=lo..int(y._t) by y._st where lo=y._t-(y._t-x._lo)/y._st*y._st +proc fill_in(x:seq(int),y:strided_range_above(any_int),t)=int(y._t)..x._hi by y._st +proc fill_in(x:seq(int),y:stride(any_int),t)=x by int(y._st) +proc fill_in(x:seq(int) or null,y:null,t)=x +proc fill_in(x:grid,y:tuple(any_int),t)=int(y) +proc fill_in(x:grid,y:tuple(subs_dim),t)=map($fill_in,x,y,spread(t,x)) +proc fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim),t)=_fill_in(x,head(y),tail(y),t) +proc _fill_in(x,y,z,t)=prepend(fill_in(x.1,y,t),_fill_in(tail(x),head(z),tail(z),t)) +proc _fill_in(x,y:stretch_dim,z,t:fix(true))=prepend(null,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x,y:stretch_dim,z,t:fix(false))=prepend(y,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x:null,y:empty_head,z,t)=null +proc _fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x:empty_head,y,z,t)=error_type() :test "Rank mismatch in slice" => fix(false) +// ******************************************************* +// SUBSCRIPT INTERSECTION AND ALIASING +// ******************************************************* +// Test for intersection between two subscripts +proc intersects(x:null,y:subs_dim)=fix(true) +proc intersects(x:subs_dim,y:null)=fix(true) +proc intersects(x:null,y:null)=fix(true) +proc intersects(x:range(any_int),y:range(any_int))=not(x._hiy._hi) +proc intersects(x:seq(any_int),y:seq(any_int))=size(intersect(x,y))>0 +proc intersects(x:range(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._hi>=y._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range(any_int))=y._hi>=x._t +proc intersects(x:range(any_int),y:range_below(any_int) or strided_range_below(any_int))=x._lo<=y._t +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range(any_int))=y._lo<=x._t +proc intersects(x:strided_range(any_int),y:range_above(any_int) or strided_range_above(any_int))=intersects(y._t..x._hi by step(y),x) +proc intersects(y:range_above(any_int) or strided_range_above(any_int),x:strided_range(any_int))=intersects(y._t..x._hi by step(y),x) +proc intersects(x:strided_range(any_int),y:range_below(any_int) or strided_range_below(any_int))=intersects(x,y._t..x._lo by -step(y)) +proc intersects(y:range_below(any_int) or strided_range_below(any_int),x:strided_range(any_int))=intersects(x,y._t..x._lo by -step(y)) +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._t>=y._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_below(any_int) or strided_range_below(any_int))=y._t>=x._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_above(any_int) or strided_range_above(any_int))=fix(true) +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_below(any_int) or strided_range_below(any_int))=fix(true) +proc intersects(x:strided_range_below(any_int),y:strided_range_above(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 +proc intersects(y:strided_range_above(any_int),x:strided_range_below(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 +proc intersects(x:strided_range_above(any_int),y:strided_range_above(any_int))=abs(x._t-y._t) mod gcd(int(x._st),int(y._st))==0 +proc intersects(x:strided_range_below(any_int),y:strided_range_below(any_int))=abs(x._t-y._t) mod gcd(abs(int(x._st)),abs(int(y._st)))==0 +proc intersects(x:stride(any_int),y:subs_dim)=fix(true) +proc intersects(x:subs_dim,y:stride(any_int))=fix(true) +proc intersects(x:stride(any_int),y:stride(any_int))=fix(true) +proc intersects(x:seq,y:int)=y in x +proc intersects(x:int,y:seq)=x in y +proc intersects(x:int,y:int)=x==y +proc intersects(x:int,y:range_above(any_int))=x>=y._t +proc intersects(x:int,y:range_below(any_int))=x<=y._t +proc intersects(x:int,y:strided_range_above(any_int))=x>=y._t and (x-y._t) mod y._st==0 +proc intersects(x:int,y:strided_range_below(any_int))=x<=y._t and (y._t-x) mod y._st==0 +proc intersects(y:range_above(any_int),x:int)=x>=y._t +proc intersects(y:range_below(any_int),x:int)=x<=y._t +proc intersects(y:strided_range_above(any_int),x:int)=x>=y._t and (x-y._t) mod y._st==0 +proc intersects(y:strided_range_below(any_int),x:int)=x<=y._t and (y._t-x) mod y._st==0 +proc _intersects(x,y,z:fix(true))=map_reduce($intersects,$and,x,y) +proc _intersects(x,y,z:fix(false))=fix(false) +proc intersects(x:tuple(subs_dim except stretch_dim),y:tuple(subs_dim except stretch_dim))=_intersects(x,y,rank(x)==rank(y)) +proc intersects(x:tuple(subs_dim),y:tuple(subs_dim))=_intersects(rx,ry,rank(rx)==rank(ry))where rx=_rigid_dims(x),ry=_rigid_dims(y) +proc intersects(x:tuple(subs_dim),y:null)=fix(true) +proc intersects(x:null,y:tuple(subs_dim))=fix(true) +proc _intersects(x:subs,y:subs)=intersects(x,y) +proc _intersects(x,y)=fix(false) +// Alias checking +proc PM__check_alias(arg...)=false +proc PM__check_alias(i,j,x,y) { + test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) +} +proc PM__check_alias(i,j,x,y,arg...) { + if _intersects(x,y):PM__check_alias(i,j,arg...) +} +// Combining subscripts +proc PM__cmbidx(x,y)=_cmb(x,y) +proc PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...) +type _cmb_error is unique +proc _cmb(x,y)=_cmb_error +proc _cmb(x:subs except index,y:subs)=_cmb1(x,y) +proc _cmb1(x,y)=_cmb_error +proc _cmb1(x:subs_dim,y:subs_dim)=x[y] +proc _cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y)) +proc _cmb2(x,y,z:fix(true))=x[y] +proc _cmb2(x,y,z:fix(false))=_cmb_error +// ******************************************************* +// ITERATION - SEQUENTIAL AND CONCURRENT +// ******************************************************* +// Iteration over mshape +// - first element +proc PM__first(d:int)=0,null,d>0 +proc PM__first(d:tuple1d)=i,s,e where i,s,e=PM__first(d.1) +proc PM__first(d:tuple2d)=[j1,j2],[s1,s2],e1 and e2 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2) +proc PM__first(d:tuple3d)=[j1,j2,j3],[s1,s2,s3],e1 and e2 and e3 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3) +proc PM__first(d:tuple4d)=[j1,j2,j3,j4],[s1,s2,s3,s4],e1 and e2 and e3 and e4 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4) +proc PM__first(d:tuple5d)=[j1,j2,j3,j4,j5], [s1,s2,s3,s4,s5],e1 and e2 and e3 and e4 and e5 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5) +proc PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],[s1,s2,s3,s4,s5,s6],e1 and e2 and e3 and e4 and e5 and e6 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6) +proc PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],[s1,s2,s3,s4,s5,s6,s7],e1 and e2 and e3 and e4 and e5 and e6 and e7 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7) +// - subsequent elements +proc PM__next(d:int,g,i)=ii,null,ii> _doloop(int)->(int) : "do_loop" +PM__intrinsic<> _doloop(int,int)->(int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int)->(int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int)->(int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int)->(int,int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int,int)->(int,int,int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "do_loop" +proc _elts(x:int)=i where i=_doloop(x) +proc _elts(x:tuple1d)=[i] where i=_elts(x.1) +proc _elts(x:tuple2d)=[i,j] where i,j=_doloop(x.1,x.2) +proc _elts(x:tuple3d)=[i,j,k] where i,j,k=_doloop(x.2,x.2,x.3) +proc _elts(x:tuple4d)=[i,j,k,l] where i,j,k,l=_doloop(x.1,x.2,x.3,x.4) +proc _elts(x:tuple5d)=[i,j,k,l,m] where i,j,k,l,m=_doloop(x.1,x.2,x.3,x.4,x.5) +proc _elts(x:tuple6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_doloop(x.1,x.2,x.3,x.4,x.5,x.6) +proc _elts(x:tuple7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7) +PM__intrinsic<> _blockedloop(any)->(int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int,int) : "blocked_loop" +proc _belts(x,y:shape1d)=[i] where i=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape2d)=[i,j] where i,j=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape3d)=[i,j,k] where i,j,k=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape4d)=[i,j,k,l] where i,j,k,l=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape5d)=[i,j,k,l,m] where i,j,k,l,m=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y)) +PM__else +proc PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n) +proc PM__generate(x:mshape,n,s)=_elts(dims(x),1,n) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=_iota(siz,0,x-1,1,tot) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +PM__endif +PM__intrinsic _indices(any)->(int) : "indices" +// ************************************** +// ARRAYS +// ************************************** +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) +type farray(e,d:shape) is e^const d,e^invar d,e^fix(d),array_template(e,d,fix(false)) +type farray(e,d:mshape) is ...,array_slice(e^const any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix(any)) +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif +PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(false))->(PM__dim x,y) : "array" +PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(true))->(PM__vdim x,y) : "var_array" +PM__intrinsic<> _redim(x:any^any,y:any)->(over x,y) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(PM__dim x,y) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(#x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(%x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + +proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) +PM__intrinsic _make_subref(a:any^mshape,i:int)->(%a) : "make_rf" +PM__intrinsic _get_aelem(x:any^any,y:int)->(%x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +// Linear index of tuple mshape (zero base,unit stride) +proc _indx(g:null,s)=fix(0) +proc _indx(g:range(int),s)=int(s) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:null)=fix(1) +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _offset(x:mshape)=x._o +proc _offset(x)=fix(0) +proc index(g:mshape1d or tuple1d_of(int),s:any_int)=int(_indx(g.1,s))+_offset(g) +proc index(g:mshape1d or tuple1d_of(int),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g) +proc index(g:mshape2d or tuple2d_of(int),s:tuple2d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2))+_offset(g) +proc index(g:mshape3d or tuple3d_of(int),s:tuple3d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3)))+_offset(g) +proc index(g:mshape4d or tuple4d_of(int),s:tuple4d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4))))+_offset(g) +proc index(g:mshape5d or tuple5d_of(int),s:tuple5d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5)))))+_offset(g) +proc index(g:mshape6d or tuple6d_of(int),s:tuple6d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6))))))+_offset(g) +proc index(g:mshape7d or tuple7d_of(int),s:tuple7d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7))))))))+_offset(g) +proc index2point(i:int,s:range(int))=[i+s._lo] +proc index2point(i:int,s:int)=[i] +proc index2point(i:int,s:tuple1d_of(int))=[i] +proc index2point(i:int,s:tuple2d_of(int))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc index2point(i:int,s:tuple3d_of(int))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple4d_of(int))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple5d_of(int))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple6d_of(int))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple7d_of(int))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} +// ***************************************** +// ARRAY TEMPLATES +// ***************************************** +// Array templates +type array_template(a,d:mshape or dshape,v:fix(bool)) is rec {_a:a,_d:d,_s:int,_v:v} +proc array(a:any,s:dshape)=new array_template { + _a=a,_d=s,_s=s._size,_v=fix(false) +} +proc array(a:any,s:mshape(tuple(range(int))))=new array_template { + _a=a,_d=s,_s=size(s),_v=fix(false) +} +proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) +proc varray(a:any,s:mshape or dshape)=new array_template { + _a=a,_d=s,_s=size(s),_v=fix(true) +} +proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) +proc _zero(x)=0 +proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) +// Treat a template as if it were an array +proc _arb(a:array_template)=a._a +proc #(a:array_template(,mshape,))=a._d +proc dims(a:array_template(,mshape,))=dims(a._d) +proc size(a:array_template)=a._s +proc redim(a:array_template,d:mshape)= new array_template { +_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s +proc element(a:array_template,arg...:subs)=a._a +// Array creation from template +proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) +proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) +proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) +// ***************************************** +// MATRIX AND VECTOR +// ***************************************** +type matrix_element is num,bool,... +type _matrix(t) is struct{use array:t} +type matrix(t:matrix_element) is _matrix(array(t,shape2d)) +type vector(t:matrix_element) is _matrix(array(t,shape1d)) +type matrix_template(t:matrix_element) is _matrix(array_template(t,shape2d)) +type vector_template(t:matrix_element) is _matrix(array_template(t,shape1d)) +proc PM__matrix(x)=new _matrix{ + array=x +} +proc vector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n)) +proc vvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n)) +proc dvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) +proc dvvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) +proc vector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(array(x,n,distr)) +proc vvector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(varray(x,n)) +proc matrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n)) +proc vmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n)) +proc dmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) +proc dvmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) +proc matrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(array(x,n,distr)) +proc vmatrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(varray(x,n)) +proc matrix_element_zero(x:num)=convert(0,x) +proc matrix_element_balance(x:num,y:num)=xx,yy where xx,yy=balance(x,y) +proc matrix_element_add(x:num,y:num)=x+y +proc matrix_element_subtract(x:num,y:num)=x-y +proc matrix_element_multiply(x:num,y:num)=x*y +proc matrix_element_zero(x:bool)=false +proc matrix_element_balance(x:bool,y:bool)=x,y +proc matrix_element_add(x:bool,y:bool)=x or y +proc matrix_element_multiply(x:bool,y:bool)=x and y +proc +(x:matrix,y:matrix) { + check_conform(x.array,y.array) + test "Cannot add zero size matrices"=>size(x)>0 + var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_add(xx,yy) return z +} +proc -(x:matrix,y:matrix) { + check_conform(x.array,y.array) + test "Cannot add zero size matrices"=>size(x)>0 + var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_subtract(xx,yy) return z +} +proc *(x:matrix,y:matrix) { + sx=#x + sy=#y + sz=[sx.1,sy.2] + test "Matrices do not conform for multiplication"=>size(sx.2)==size(sy.1) + test "Cannot multiply zero size matrices"=>size(x)>0 and size(y)>0 + var z=matrix(b,sz) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for *i in sz,zz in z.array { + var s=matrix_element_zero(_arb(z.array)) + foreach invar k in #(sx.1) { + s=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2])) + } + zz=s + } + return z +} + +// ***************************************** +// DISTRIBUTED SHAPE (DSHAPE) +// ***************************************** +type _distrb(extent:extent,dist:distr or null) +type _distrb(extent:extent,dist:distr) is ...,dshape(extent,dist) +type _distrb(extent:extent,dist:null) is ...,mshape(extent) +type shape(extent:extent,dist:distr or null) is _distrb(extent,dist) +type shape1d(extent:extent1d,dist:distr or null) is shape(extent,dist) +type shape2d(extent:extent2d,dist:distr or null) is shape(extent,dist) +type shape3d(extent:extent3d,dist:distr or null) is shape(extent,dist) +type shape4d(extent:extent4d,dist:distr or null) is shape(extent,dist) +type shape5d(extent:extent5d,dist:distr or null) is shape(extent,dist) +type shape6d(extent:extent6d,dist:distr or null) is shape(extent,dist) +type shape7d(extent:extent7d,dist:distr or null) is shape(extent,dist) +type PM__distr_tag is unique +type dshape(extent:extent,dist:distr) is rec {use _mshape:mshape(extent),dist:dist,_tile,_tilesz,_size:int,_level:int,_dtag:PM__distr_tag} +proc check_conform(x:dshape,y:mshape) { + check_conform(x._mshape,y) +} + +proc check_conform(x:mshape,y:dshape) { + test "A distributed object connot conform to a non-distributed value" => fix(false) +} + +proc check_conform(x:dshape,y:dshape) { + check_conform(x._mshape,y._mshape) + test "Objects have different distributions"=> x.dist==y.dist +} + +proc conform(x:dshape,y:mshape)=conform(x._mshape,y) +proc conform(x:mshape,y:dshape)=fix(false) +proc conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist +proc _local_size(x:dshape)=size(x._tile) +// Get an element from a null tile - just pass index through +proc element(x:null,y:tuple(index))=y +proc element(x:null,y:int)=y +proc size(d:dshape)=d._size +proc dims(d:dshape)=dims(d._mshape._extent) +proc #(d:dshape)=new dshape{ + _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level,_dtag=d._dtag +} +proc [](d:dshape,s:index)=d._mshape._extent[s] +proc [](d:dshape,s:subs)=_dshape_slice(d,ss) where ss=fill_in(#d._mshape._extent,s,fix(true)){ + check_contains(#(d._mshape._extent),s) +} + +proc _dshape_slice(d:dshape,ss)=new dshape{ +_mshape=shape(#active_dims(ss)),dist=dist,_tile=tile,_tilesz=#tile,_size=size(tile),_level=d._level,_dtag=d._dtag} where tile=element(dist,_shrd_node()) where dist=sliced_distr(d.dist,ss) +// ***************************************** +// DISTRIBUTED ARRAY AND SHAPE TEMPLATES +// ***************************************** +type darray_template(e,d,p,t) is rec {_e:e,_d:d,_p:p,_t:t,_v} +type dshape_template(d,p,t) is rec {_d:d,_p:p,_t:t} +proc darray(e,d:extent)=array(e,d,VBLOCK) +proc array(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { + _e=e,_d=d,_p=distr,_t=topo,_v=fix(true) +} +proc array(e,d:extent,distr:null or tuple(null))=array(e,d) +proc dvarray(e,d:extent)=varray(e,d,VBLOCK) +proc varray(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { + _e=e,_d=d,_p=distr,_t=topo,_v=fix(true) +} +proc varray(e,d:extent,distr:null or tuple(null))=varray(e,d) +proc shape(d:extent,distr,topo:any=null)=new dshape_template { + _d=d,_p=distr,_t=topo +} +// ***************************************** +// DISTRIBUTED ARRAYS +// ***************************************** +proc PM__dup(d:darray_template) { + dd=dims(d._d) + topo=topology(d._t,d._p,dd, min(size(d._d),shrd_nnode())) + dist=distribute(d._p,dd,topo) + test "Not enough processors to implement distribution"=> size(#dist)<=shrd_nnode() + p=_shrd_node() + var elem=empty(dist) + if p size(#dist)<=shrd_nnode() + p=_shrd_node() + var elem=empty(dist) + if p fix(false) +proc _arb(dd:any^dshape)=_get_aelem(dd,0) +proc dims(dd:any^dshape)=dims((#dd)._mshape) +proc PM__redim(a,d)=_redim(a,d) +proc PM__local(a:any^dshape)=_redim(a,(#a)._tilesz) +proc PM__local(a:any^mshape)=a +proc PM__local%(x:shared) shared =PM__local(x) +proc element(a:any^dshape,t) { + p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) + var r=_arb(a) + if p==_this_node():r=_get_aelem(a,i) + _bcast_shared(&r,p) + return r +} + +proc _set_elem(&a:any^dshape,v,t) { + p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) + if p==_this_node():PM__setaelem(&a,i,v) +} + +// ************************************************* +// SLICES +// ************************************************* +// Slices +type array_slice(a,s) is struct^{_a:a,_s:s} +proc _arb(x:array_slice)=_arb(x._a) +proc #(x:array_slice)=#(x._s) +proc #(x:array_slice(any^dshape))=_dshape_slice(d,d._mshape._extent#x._s) where d=#(x._a) +proc conform(x:mshape,y:array_slice)=map_reduce($_conform,$and,x,y._s) +proc conform(x:dshape,y:array_slice)=map_reduce($_conform,$and,x._mshape,y._s) +proc conform(x,y:array_slice)=map_reduce($_conform,$and,#x,y._s) +proc dims(x:array_slice)=dims(x._s) +proc size(x:array_slice)=size(x._s) +proc element(x:array_slice(any^mshape,),y:index)=element(x._a,x._s[y]) +proc element(x:array_slice,y:subs)=new array_slice { + _a=x._a,_s=x._s[y] +} +proc _set_elem(&x:array_slice(any^mshape,),v,y:index) { + PM__setaelem(&^(x._a),index(#(x._a),x._s[y]),v) +} +proc PM__dup(x:array_slice(any^mshape,)){ + var a=array(_arb(x),#x) + a=x + return a +} +proc PM__dup(x:array_slice(any^dshape,)){ + d=#x._a + ss=(#x._a)._mshape#x._s + var a=array(_arb(x._a),_dshape_slice(d,ss)) + _set_slice(&^(PM__local(a)),#(#a)._tile, PM__local(x._a),overlap((#x._a)._tile,ss)) + return a +} +// ************************************************* +// ARRAY & SLICE ASSIGNMENT +// ************************************************* +proc PM__assign(&xx:farray,x:any) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign(&xx:farray,x:array) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign(&xx:varray,x:any except varray) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign(&xx:varray,x:farray) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign_var(&xx:farray,x:any) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign_var(&xx:farray,x:array) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign_var(&xx:varray,x:any except varray) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign_var(&xx:varray,x:farray) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__aliased_assign(&xx,x){ +} +proc PM__aliased_assign(&xx:array_slice,x:array_slice) <> { + _assign_internal_slice(&xx,x._s) +} +proc _array_assign(&xx,x,v:fix(false)){ + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc _array_assign(&xx,x,v:fix(true)){ + check_conform(extent(#xx),extent(#x)) + if _copy_array(&xx,x):_sync_messages(xx,x) +} +proc _array_assign(&xx:array_slice,x:array_slice,v:fix(true)){ + check_conform(extent(#xx),extent(#x)) + if _copy_array(&xx,x):_sync_messages(xx,x) +} +proc _array_assign(&xx:varray,x,v:fix(true)) { + _assign_element(&xx,x) +} +proc _array_assign(&xx:varray,x:array_template,v:fix(true)) { + _assign_element(&xx,PM__dup(x)) +} +PM__if_compiling +proc _set_slice(&x,a,y,b) { + foreach i in a,j in b:x[i]=y[j] +} +PM__else +proc _set_slice(&x,a,y,b) { + if size(a)>0:forall i in a,j in b{ + sync x[i]=y[j] + } +} +PM__endif +type _non_d is any^mshape,array_slice(any^mshape,) +proc _set_array(&x:any^mshape,y){ + forall i in x { + _assign(&i,y) + } +} + +proc _set_array(&x:any^dshape,y){ + _set_array(&^(PM__local(^(&x))),y) +} +proc _set_array(&x:array_slice(any^mshape,),y){ + forall i in x._s { + _set_elem(&x._a,y,i <>) + } +} +proc _set_array(&x:array_slice(any^dshape,),y){ + tile=(#x._a)._tile + t=overlap(tile,((#x._a)#x._s)) + forall i in t { + _set_elem(&x._a,y,i <>) + } +} + +proc _copy_array(&a:_non_d,b:_non_d){ + forall i in a, j in b { + i=j + } + return fix(false) +} +proc _copy_array(&xx:any^dshape,x:_non_d) { + tile=(#xx)._tile + forall i in tile { + PM__setaelem(&xx,index(dims(tile),here),x[(#x)[i]] <>) + } + return fix(false) +} +proc _copy_array(&xx:array_slice(any^dshape,),x:_non_d) { + tile=(#xx._a)._tile + subtile,subarray=overlap(tile,(#xx._a)._mshape#xx._s) + forall i in subtile,j in subarray { + PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <>) + } + return fix(false) +} + +proc _copy_array(&a:_non_d,x:any^dshape) { + dist=(#x).dist + foreach p in #(dist) { + tile=element(dist,p) + i=index(dims(dist),p) + if i==_shrd_node() { + forall kk in PM__local(x),j in tile { + var k=kk + _bcast_shared(&k,i) + _set_elem(&a,k,(#a)[j] <>) + } + } else { + forall j in tile { + var k=_arb(a) + _bcast_shared(&k,i) + _set_elem(&a,k,(#a)[j] <>) + } + } + } + return fix(false) +} + +proc _copy_array(&v:_non_d,x:array_slice(any^dshape,)) { + dist=(#(x._a)).dist + xs=(#(x._a))._mshape#x._s + nodes=#dist + foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) { + p=nodes[pp] + utile,elem=overlap(dist[nodes[p]],xs) + i=index(dims(dist),p) + if i==_shrd_node() { + forall j in utile, jj in elem { + var k=element(PM__local(x._a),j) + _bcast_shared(&k,i) + _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>) + } + } else { + forall j in elem { + var k=_arb(x._a) + _bcast_shared(&k,i) + _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>) + } + } + } + return fix(false) +} + +proc _copy_array(&x:any^mshape,y:array_template) { + _set_array(&x,y._a) + return fix(false) +} +proc _copy_array(&x:any^dshape,y:array_template) { + _set_array(&^(PM__local(^(&x))),y._a) + return fix(false) +} +type _comp is contains(array or *any or ^*(,,,,)) +proc _copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) { + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#(xx._a),xd=#(x._a) + return fix(true) +} + +proc _copy_array(&xx:any^dshape,x:array_slice(any^dshape)) { + _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#xx,xd=#(x._a) + return fix(true) +} + +proc _copy_array(&xx:array_slice(any^dshape,),x:any^dshape) { + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#(xx._a),xd=#x + return fix(true) +} + +proc _copy_array(&xx:any^dshape,x:any^dshape) { + _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#xx,xd=#x + return fix(true) +} + +proc _assign_internal_slice(&xx:array_slice(any^mshape),s) { + x=new array_slice{ + _a=xx._a,_s=s + } + xx=x +} +proc _assign_internal_slice(&xx:array_slice(any^dshape),s) { + xxd=#(xx._a) + xxs=xxd._mshape#xx._s + xs=xxd._mshape#s + ltile=intersect(xxd._tile,xs) + ls=#ltile + var x=array(_arb(xx),ls) + _set_slice(&x,ls,PM__local(xx._a),overlap(xxd._tile,ltile)) + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxs, x,xxd,xxd._mshape#s,ltile) +} + +proc _copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) { + _push_node_dist() + oldpart,oldtile=overlap(xs,oldd._tile) + newpart,newtile=overlap(xxs,newd._tile) + if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { + p=index(dims(oldd.dist),pp) + if p/=_this_node() { + tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) + ov=overlap(newd._tile,tile) + if size(ov)>0:_recv_slice(p,&xx,ov) + } + } + if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { + p=index(dims(newd.dist),pp) + if p/=_this_node() { + tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) + ov=overlap(otile,tile) + if size(ov)>0:_send_slice(p,x,ov) + } + } + if size(newpart)>0 and size(oldpart)>0 { + oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) + _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) + } + PM__pop_node(newd) +} + +proc _copy_darray_slice(&xx:_comp^any,newd,xxs,x,oldd,xs,otile) { + _push_node_dist() + oldpart,oldtile=overlap(xs,oldd._tile) + newpart,newtile=overlap(xxs,newd._tile) + if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { + p=index(dims(newd.dist),pp) + if p/=_this_node() { + tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) + ov=overlap(otile,tile) + if size(ov)>0:_send_slice(p,x,ov) + } + } + if size(newpart)>0 and size(oldpart)>0 { + oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) + _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) + } + if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { + p=index(dims(oldd.dist),pp) + if p/=_this_node() { + tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) + ov=overlap(newd._tile,tile) + if size(ov)>0:_recv_slice_sync(p,&xx,ov) + } + } + PM__pop_node(newd) +} + +proc _xp(x:single_point,y)=single_point(low(y)) +proc _xp(x,y)=y +// ************************************************* +// REFERENCES (SUBSCRIPTS AND SLICES) +// ************************************************* +// Reference type for & args +type PM__reftype(x) is x,^shared(x,,,,) +// Support for internal ^(...) reference type +PM__intrinsic _v1(x:any)->(PM__d1 x) : "elem"(1) +PM__intrinsic _v2(x:any)->(PM__d2 x) : "elem"(2) +PM__intrinsic _v3(x:any)->(PM__d3 x) : "elem"(3) +PM__intrinsic _v4(x:any)->(PM__d4 x) : "elem"(4) +PM__intrinsic _v5(x:any)->(PM__d5 x) : "elem"(5) +PM__intrinsic _v1%(r:any,s:any,h:any,x:any)->(PM__d1% x) : "elem"(1) +PM__intrinsic _v2%(r:any,s:any,h:any,x:any)->(PM__d2% x) : "elem"(2) +PM__intrinsic _v3%(r:any,s:any,h:any,x:any)->(PM__d3% x) : "elem"(3) +PM__intrinsic _v4%(r:any,s:any,h:any,x:any)->(PM__d4% x) : "elem"(4) +PM__intrinsic _v5%(r:any,s:any,h:any,x:any)->(PM__d5% x) : "elem"(5) +// Right hand side references +proc _make_null(x)=null +proc PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) +proc PM__subref(x,t:subs){ + tt=_tup(t) + check_contains(#x,tt) + return _subref(x,tt) +} +proc PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x)) +proc PM__subref(x:^*(,,,,),t:null)=PM__subref(x,map($_make_null,#_v1(x))) +proc _subref(x:any^mshape,t:index)=element(x,t) +proc _subref(x:any^any,t:subs)=new array_slice { + _a=x,_s=fill_in(#x,t,fix(true)) +} +proc _subref(x:array_slice(any^mshape,),t:index)=element(x._a,x._s[t]) +proc _subref(x:array_slice,t:subs)=new array_slice { + _a=x._a,_s=x._s[t] +} +proc _subref(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) +proc _subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t]) +proc _subref(a:^*(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc _subref(a,t)=$[](a,t) +proc [](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...))) +// Left hand side references +proc PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) +proc PM__sublhsamp(x,t:subs) { + tt=_tup(t) + check_contains(#x,tt) + return _sublhs(x,tt) +} +proc PM__sublhsamp(x:any^dshape,t:subs) { + test "Cannot have subscript of a distributed array in ""&"" argument"=>fix(false) + return _arb(x) +} + +proc PM__sublhs(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) +proc PM__sublhs(x,t:subs) { + tt=_tup(t) + check_contains(#x,tt) + return _sublhs(x,tt) +} +proc PM__sublhs(x:^!(,,,,),t:subs) { + tt=_tup(t) + return _sublhs(x,tt) +} +proc PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x)) +proc PM__sublhs(x:^!(,,,,),t:null)=PM__sublhs(x,map($_make_null,#_v1(x))) +proc _sublhs(x:any^mshape,t:index)=_make_subref(x,t) +proc _sublhs(x:any^any,t:subs)=new array_slice { + _a=x,_s=fill_in(#x,t,fix(true)) +} +proc _sublhs(x:array_slice(any^mshape,),t:index)=_make_subref(x._a,x._s[t]) +proc _sublhs(x:array_slice,t:subs)=new array_slice { + _a=x._a,_s=x._s[t] +} +proc _sublhs(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) +proc _sublhs(a:^!(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc [](&a:array,v,arg...){ + PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v) +} + +// Realise a reference +proc PM__valref(x)=x +proc PM__valref(x:^*(,,,,)) { + var v=_v1(x) + if _v4(x)==_shrd_node() { + v=_getref(x,null) + } + _bcast_shared(&v,_v4(x)) + return v +} + +// Assign to a reference +proc PM__assign(&x:^*(,,,,),y) { + check_assign_types(_v1(^(&x)),y) + if _v4(^(&x))==_shrd_node() { + PM__assign(&^(_getlhs(^(&x),null)),y) + } +} + +proc PM__assign(&x:^*(,,,,),y,p:assignment_operator) { + if _v4(^(&x))==_shrd_node() { + PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) + } +} + +// ************************************************************* +// DISTRIBUTED REFERENCES +// ************************************************************* +// Distributed reference is an internal compiler type +// ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode) +// mode is: +// null -- local reference +// _s_ref -- shrd index on darray, only shrd/indexed otherwise +// _sp_ref -- shrd index on darray, some priv after (or before) +// _d_ref -- indexed index on darray, shrd/indexed otherwise +// _dp_ref -- indexed index on darray, some priv after (or before) +// _p_ref -- priv index on darray and possibly elsewhere +type _s_ref is unique +type _sp_ref is unique +type _d_ref is unique +type _dp_ref is unique +type _p_ref is unique +PM__intrinsic _import_dref%(r:any,s:any,h:any,x:any)->(^^x) : "import_dref" +// Some trivial referencing cases +proc PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t) +proc PM__sublhsamp%(x:any^dshape,t:subs) { + test "Cannot have subscript of a distributed array in ""&"" argument"=>fix(false) + return _arb(x) +} + +proc PM__sublhs%(x,y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv ^*(,,,,),y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>fix(false) +proc PM__subref%(x:priv,y)=PM__subref(x,y) +proc PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y) +proc PM__subref%(x:priv,y:invar indexed)=PM__subref(x,*y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:index)=PM__subref(x,y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:subs)=PM__subref(x,y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:invar indexed)=PM__subref(x,_dmap(y,here)) +proc PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>fix(false) +proc PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y) +proc PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y) +proc PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y)) +// Reference of non-distributed array with priv or indexed subscript +proc PM__subref%(x:invar any^mshape,t:index){ + tt=_tup(t) + check_contains(#x,tt) + i=index(#x,tt) + return PM__dref(_get_aelem(x,i),x,i,null,null) +} +proc PM__subref%(x:invar any^mshape,t:subs){ + tt=_tup(t) + check_contains(#x,tt) + return PM__drefs(x,x,tt,null,null) +} +proc PM__subref%(x:invar any^mshape,t:invar indexed)=PM__subref%(x,_dmap(t,here)) +proc PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t]) +proc PM__subref%(x,t)=PM__dref($[](x,t),x,t,null,null) +// Subscript or slice of distributed array +proc PM__subref%(x:shared any^dshape,t:invar index) complete <>{ + tt=_tup(t) + check_contains(#(x),tt) + return PM__dref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) +} +proc PM__subref%(x:shared any^dshape,t:index){ + tt=_tup(t) + check_contains(#(x),tt) + return PM__dref(_arb(x),x,i,p,_p_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) +} +proc PM__subref%(x:shared any^dshape,t:subs){ + tt=_tup(t) + check_contains(#(x),tt) + var xx=varray(_arb(x),empty(#x)) + return PM__drefs(xx,x,tt,p,_p_ref) where p=nodes_for_grid((#x).dist,tt) +} +proc PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t) +proc PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond { + check_contains(#x,_dmap(t,here)) + return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t) +} +proc PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t) +// Subscript or slice of non-distristuted array which is itself result of variant slice +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + i=index(#(_v1%(x)),tt)return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){ + tt=_tup%(t) + check_contains(#_v1%(x),tt) + i=index(#(_v1%(x)),tt) + return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) { + tt=_tup(t) + check_contains(#(_v1%(x)),tt) + return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +// Subscript or slice of darray which is itself the result of a priv subscript +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt) +} +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:subs){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) where p=nodes_for_grid((#_v1%(x)).dist,tt) +} +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +// Subscript of a priv slice +proc PM__subref%(x:priv ^#(,,,null,null),t:subs)=PM__subref%(_v2%(x),_v3%(x)[_tup(t)]) +proc PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)=PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here) +// Subscript of distributed reference +proc _arb%(x:partial)=_arb(x) +proc _arb%(x:complete) complete <>=_arb(x) +proc _arb%(x:chan) complete <>=_arb(x) +proc _arb%(x:invar) complete <>=_arb(x) +proc PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref) +proc PM__subref%(x:priv ^*(any^any,,,,),t:invar indexed)=PM__subref%(x,_dmap(_tup(t),here)) +proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref) +// Node .[] subscript of distributed array +type _lcl is unique{_LCL} +proc PM__nodelhs%(x,y)=PM__noderef%(x,y) +proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)=^(PM__import_val(PM__local(x)),coherent) +proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(region:dshape,x:shared any^dshape,y:priv any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)where p=index(xd,y) +} +proc PM__noderef%(region:dshape,x:shared any^dshape,y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:invar any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:priv any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x,y)=error_type() { + if not region is { + test """.[]"" subscript in non-distributed region"=>fix(false)} elseif x is { + test """.[]"" subscript cannot be applied to a mirrored array"=>fix(false)} elseif not x is { + test """.[]"" subscript applied to a non-array"=>fix(false)} elseif not y is { + test """.[]"" subscript must have an integer value"=>fix(false)} else { + test "Incorrect "".[]"" subscript"=>fix(false) + } +} + +// May need to cap off reference with here +type _here(t) is rec {here:t} +proc _cap%(x,h)<>=x +proc _cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here { + here=h +} +) +proc _capn%(x,h)<>=PM__dref(_v1%(x),x,new _here { + here=h +} +) +// Treat ! variables differently only for limited circumstances in drefs +proc _drat(at,tile,t)=fix(false) +proc _drat(at:fix(true),tile:tuple(range or block_seq),t:indexed and _dr)=fix(true) +type _di(n) is indexed_dim(fix(1),fix(1),,n) or int +type _dr is [_di(fix(1))],[_di(fix(1)),_di(fix(2))],[_di(fix(1)),_di(fix(2)),_di(fix(3))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5)),_di(fix(6))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5)),_di(fix(6)),_di(fix(7))] +// Resolve a distributed reference +proc PM__getref%(x,at)=x +proc PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x) +proc PM__getref%(x:priv ^*(,,,int,_p_ref),at) { + PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) + return v +} +proc PM__getref%(x:priv ^*(,,,int,_sp_ref),at) { + PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) + return v +} +proc _scatter(x,region) { + if _this_node()==_v4(x):foreach node in #region.dist { + d=#region._mshape + a={ + _getref(_import_dref%(x),j): j in d + } + p=index(dims(region.dist),node) + _send_slice(p,a,region.dist[node]) + } +} + +proc PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> { + chan var xx=_v1%(x) + _getref_s%(&xx!,^^(x),at) + _bcast_shared(&xx) + return xx +} +proc _getref_s%(&xx:invar,x:invar,at:invar) PM__node { + PM__head_node{ + _irecv(_v4(x),&xx) + } + _scatter(x,region) + _sync_messages(xx,x) +} +proc PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{ + chan var xx=_v1%(x) + _getref_sc%(&xx!,^^(x),at) + _bcast_shared(&xx) + return xx +} +proc _getref_sc%(&xx:invar,x:invar,at:invar) PM__node { + _scatter(x,region) + PM__head_node{ + _recv(_v4(x),&xx) + } + _sync_messages(xx,x) +} +proc PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> { + chan var a=_v1%(x) + _getref_d%(&^(PM__local%(^(&a!))),^^(x),at <>) + _bcast_shared(&a) + return a +} + +proc _getref_d%(&a:invar,x:invar,at:invar) PM__node { + _get_dindex_from_dref(&a,x,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) +} +proc PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> { + chan var a=_arb(_v2%(x)) + _getref_dc%(&a!,^^(x),at <>) + _bcast_shared(&a) + return a +} +proc _getref_dc%(&a:invar,x:invar,at:invar) PM__node { + PM__head_node{ + _get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) + } +} + +proc PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> { + chan var a=_v1%(x) + _getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>) + _bcast_shared(&a) + return a +} +proc _getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node { + PM__head_node{ + _get_dindex_from_ref(&a,x,t.2, _local_region(region._tile,subregion(schedule)),region, t.1,atq,_drat(at,region._tile,t.1)) + } +} +proc PM__getref%(x:priv ^#(,,,,),at) { + var v=varray(_arb(_v1%(x)),#_v3%(x)) + var vv=varray(_arb(_v1%(x)),empty(#_v1%(x))) + foreach p in _v4%(x) { + dist=(#(_getref(_v2%(x),null))).dist + u=overlap(_v3%(x),dist[p]) + ppp=index(dims(dist),p) + PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null) + v[u]=vvv + } + return v +} + +// Resolve reference locally (once communicated) +proc _getref_elem(x:any^mshape,i)=_get_aelem(x,i) +proc _getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i) +proc _getref(x:^*(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x)) +proc _getref(x:^*(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here) +proc _getref(x:^*(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)] +proc _getref(x:^*(,,null,,),y)<>=_getref(_v2(x),y) +proc _getref(x:^*(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y)) +proc _getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x) +proc _getref(x:^shared(,null,null,null,null),y)<>=_v1(x) +proc _getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x)) +proc _getslice(x:any^dshape,tt) { + t=overlap((#x)._tile,tt) + var v=varray(_arb(x),#t) + v=PM__local(x)[t] + return v +} +proc _getslice(x:any^mshape,t) { + var v=varray(_arb(x),#t) + v=x[t] + return v +} +proc _getref(x:any^any,y)=x +proc _getref(x:^shared(,,indexed,,),y)<>=_getref(_v2(x),y)[_dmap(_v3(x),y)] +proc _getref(x:^shared(,any^dshape,indexed,,),y)<>=element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) :test "Internal error - uncapped dref" => fix(false) +PM__if_compiling +PM__intrinsic _sync%(any,any,any,&x:any): "sync" +PM__else +proc _sync%(&x:any){ +} +PM__endif +// Assignment of distributed and/or shared or uniform references +proc PM__assign%(&x:priv,y,at) { + _sync%(&x) + PM__assign(&x,y <>) +} +proc PM__assign%(&x:invar,y,at) { + _sync%(&x) + _assign_to_invar%(&x,y) +} +proc _assign_to_invar%(&x:uniform,y:invar) complete { + PM__assign(&x,y <>) +} + +proc _assign_to_invar%(&x:shared,y:invar) shared{ + PM__assign(&x,y) +} + +proc _assign_to_invar%(&x:invar,y:priv) { + test "Can only assign an ""invar"" value to an ""invar"" variable" => fix(false) +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,fix(false) { + test "Cannot assign element twice in same assignment"=> _getref(xx,null)==yy + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y) + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y,at) { + foreach invar p in 0..size(#region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + } + foreach invar p in 0..size(#region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + test "Cannot assign an element two different values in a single assignment"=> _getref(xx,null)==yy + } + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,at) { + _sync%(&x) + var xx=_import_dref%(x) + PM__assign(&^(_getlhs(^(&xx),here)),y) +} +proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,at) { + _sync%(&x) + PM__assign(&^(_v1%(^(&x))),y) +} +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,fix(false) { + test "Cannot assign element to two different values in same assignment"=> _getref(xx,null)==yy + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:invar,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y)) + } +} + +proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) { + _set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)), $_just_assign,^^(^??),at,_v4(x) <>) +} +*/ +proc _just_assign(x,y)=y +/* +proc _set_ref_dp%(&x:invar,y:invar, prc:invar,atq:invar,at:invar,t:invar) PM__node { + _set_dindex_of_ref(&x,y,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,prc,atq,at) +} + +// Operater assignment: x =y +proc PM__assign%(&x:priv,y:priv,pr,at) { + PM__assign(&x,y,pr) +} +proc PM__assign%(&x:priv,y:invar,pr,at) { + PM__assign(&x,y,pr) +} +proc PM__assign%(&x:invar,y,pr,at) { + _assign_to_invar%(&x,y,pr,at) +} + +proc _assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete{ + PM__assign(&x,y,pr <>) +} + +proc _assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared { + PM__assign(&x,y,pr) +} + +proc _assign_to_invar%(&x:invar,y:priv,pr,at){ + _assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at) +} +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,pr,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) { + foreach invar p in 0..size(region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,pr,at) { + var xx=_import_dref%(x) + PM__assign(&^(_getlhs(^(&xx),here)),y,pr) +} +proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,pr,at) { + PM__assign(&^(_v1%(^(&x))),y,pr) +} +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:priv,pr,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) { + _set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,pr,^^(^??),at <>)where t=_v4%(x) +} +// Resolve LHS reference (locally after communication) +proc _getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here) +proc _getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:^(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:^shared(,,null,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:^shared(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:^(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _getlhs(x:^shared(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t)) +proc _getlhs(x:^#(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:^#shared(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x) +proc _getlhs(x:^shared(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:^(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:any^any,y)=x +proc _getlhs(x:any^dshape,y)=PM__local(x) +proc _getlhs(x:^shared(,,indexed,,),y)<>=_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y)) +proc _getlhs(x:^shared(,any^dshape,indexed,,),y)<>=_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getlhs(x:^shared(,,indexed,,),y:null)=_v1(x) :test "Internal error -- uncapped indexed ref" => fix(false) +// ************************************************************** +// INDEXED VARIABLES +// ************************************************************** +type indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m=fix(1),_c:c=fix(0),_d:d=fix(1),_n:n} +type indexed(t:int) is tuple(indexed_dim or int) except tuple(int) +proc PM__makeidxdim(x:null,y)=new indexed_dim { + _n=y +} +proc PM__makeidxdim(x:null)=new indexed_dim { + _n=null +} +proc PM__makeidxdim(x:range,y)=new indexed_dim { + _c=x._lo,_n=y +} +proc PM__makeidxdim(x:strided_range,y)=new indexed_dim { + _c=x._lo,_m=x._st,_n=y +} +proc PM__makeidxdim(x,y)=PM__makeidxdim(get_dim(x,y),y) +proc PM__makeidxdim(x:tuple)=map($PM__makeidxdim,x,indices(x)) +proc PM__makeidxdim(x:seq)=[PM__makeidxdim(x,fix(1))] +proc PM__makeidx(x:indexed_dim or indexed)=new _indexed { + _t=_tup(x),_r=null +} +proc PM__makeidx(x:indexed_dim or indexed,y)=new _indexed { + _t=_tup(x),_r=y +} +proc PM__makeidx(x,y)=x :test "Malformed indexed expression" => fix(false) +proc PM__makeidx(x)=x :test "Malformed indexed expression" => fix(false) +proc *%(x:indexed)=_dmap(x,here) +proc *%(x)=here check"""*"" operator can only be applied to an ""indexed"" value"=>fix(false) +proc *(x)=x check"""*"" operator cannot be applied outside of a parallel context"=>fix(false) +proc +(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc +(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc -(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c-y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc -(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=-x._m,_c=-x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc *(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) +proc *(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) +proc /(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c,_d=x._d*y,_n=x._n} where y=int(yy) +proc +(x:indexed_dim,y:indexed_dim)=new indexed_dim { + _m=x._m*y._d+y._m*x._d,_c=x._c*y._d+y._c*x._d,_d=x._d*y._d,_n=x._n +} +proc -(x:indexed_dim,y:indexed_dim)=new indexed_dim { + _m=x._m*y._d-y._m*x._d,_c=x._c*y._d-y._c*x._d,_d=x._d*y._d,_n=x._n +} +proc string(x:indexed_dim)="($here."++x._n++"*"++x._m++"+"++x._c++")/"++x._d +proc string(x:indexed_dim(fix(1)))="$here."++x._n++"*"++x._m++"+"++x._c +proc string(x:indexed_dim(fix(1),fix(1)))="$here."++x._n++"+"++x._c +proc string(x:indexed_dim(fix(1),fix(1),fix(0)))="$here."++x._n +proc _correct(x:indexed,y:extent)=map($-,x,low(y)) +proc _dmap(x:any_int,n:int)=x +proc _dmap(x:any_int,n:grid_slice_dim)=single_point(x) +proc _dmap(x:any_int,n:tuple(int))=x +proc _dmap(x:any_int,n:tuple(grid_slice_dim))=single_point(x) +proc _dmap(x:indexed_dim,n:int)=(n*x._m+x._c)/x._d +proc _dmap(x:indexed_dim,n:tuple)=_dmap(x,get_dim(n,x._n)) +proc _dmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi)where lo=_dmap(x,low(n)),hi=_dmap(x,high(n)) +proc _dmap(x:indexed_dim(fix(1),fix(1)),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st +proc _dmap(x:indexed_dim(fix(1),fix(1)),n:block_seq)=block_seq(n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) +proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)=map_const($_dmap,x,n) +proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)=s#map_const($_dmap,x,n) +type _round_up is unique +type _round_down is unique +proc _dunmap(x:indexed_dim,n:null)=null +proc _dunmap(x:indexed_dim,n:int,r:_round_down)=(n*x._d-x._c)/x._m +proc _dunmap(x:indexed_dim,n:int,r:_round_up)=(n*x._d+x._m-sign(1,x._m)-x._c)/x._m +proc _dunmap(x:indexed_dim,n:tuple)=_dunmap(get_dim(n,x._n),x) +proc _dunmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up) +proc _dun(x:indexed_dim,m,n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m))) +proc _dun(x:int,m,n:extent)=n +proc _dunmap(x:indexed,m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n) +proc _dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,n) +// Given tile and global region (which may be null) compute local region +proc _local_region(t,r:null)=t +proc _local_region(t,r)=intersect(t,r) +proc _root_node(at:fix(true))=_root_node() +proc _root_node(at:fix(false))=_this_node() +// Resolve x[indexed] +proc _get_dindex(&a,x,shapex,local_tile,local_region,t:indexed,at) { + tt=_correct(t,shapex._mshape) + if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) { + if at or a is <_comp^any> { + _get_dindex_ss(&a,x,shapex,local_tile,local_region,tt,at) + } else { + _get_dindex_s(&a,x,shapex,local_tile,local_region,tt,at) + } + } else { + if at or a is <_comp^any> { + _get_dindex_rs(&a,x,shapex,local_tile,local_region,tt,at) + } else { + _get_dindex_r(&a,x,shapex,local_tile,local_region,tt,at) + } + } +} + +// Resolve x[indexed] for cases where size(x[indexed])>=size(region) +// -- in this case send one value for every point in current (sub)region +proc _get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + PM__head_node{ + shapexx=#shapex._mshape + this_tile=shapex._tile + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(shapex.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) + } + } + } + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) + _sync_messages(a,x) + } +} + +// Resolve x[indexed] for cases where size(x[indexed])<=size(region) +// -- in this case send those values in x which are needed to calculate x[indexed] +proc _get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + shapexx=#shapex._mshape + src_range=_dmap(t,local_tile) + var b=array(_arb(a),#src_range) + foreach p in nodes_for_grid(shapex.dist,src_range) { + if contains(#(shapex.dist),p) { + i=index(dims(shapex.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(src_range,other_tile) + if size(portion_to_send)>0:_recv_slice(i,&b,active_dims(src_range,portion_to_send)) + } + } + } + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + src_range2=_dmap(t,other_tile) + portion_to_send=overlap(shapex._tile,src_range2) + if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) + } + } + } + u,v=overlap(src_range,shapex._tile) + forall i in u,j in v{ + _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) + } + _sync_messages(x,b) + _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) +} + +// Resolve x[indexed] for cases where size(x[indexed])>=size(region) +// -- in this case send one value for every point in current (sub)region +// -- Version for more complex types that need sync receive +proc _get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0 { + _recv_slice_sync(i,&a,portion_to_recv) + } + } + } + } + _sync_messages(a,x) +} + +// Resolve x[indexed] for cases where size(x[indexed])<=size(region) +// -- in this case send those values in x which are needed to calculate x[indexed] +// -- Version for more complex types that need sync receive +proc _get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) { + PM__head_node { + shapexx=#shapex._mshape + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + src_range=_dmap(t,other_tile) + portion_to_send=overlap(shapex._tile,src_range) + if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) + } + } + } + } + src_range=_dmap(t,local_tile) + var b=array(_arb(a),#src_range) + if _head_node() or at { + u,v=overlap(src_range,shapex._tile) + forall i in u,j in v { + _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) + } + foreach p in nodes_for_grid(shapex.dist,src_range) { + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(src_range,other_tile) + if size(portion_to_send)>0{ + PM__head_node{ + _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send)) + } + if at:_bcast_slice_shared(&b,active_dims(src_range,portion_to_send)) + } + } + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) + _sync_messages(x,b) +} + +proc _copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) { + u=overlap(a_tile,_dunmap(t,b_tile,a_extent)) + forall i in u { + j=b_tile#_dmap(t,a_tile[i]) + if j in #b_tile:_set_elem(&a,PM__getelem(b,j),i <>) + } +} + +proc _copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) { + u=intersect(a_tile,_dunmap(t,b_tile,a_extent)) + forall i in u { + bb=_import_dref%(b) + _set_elem(&a,_getref(bb,i),a_tile#i <>) + } +} + +// Resolve x[ indexed ][ indexed or shared ] ... +proc _get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) { + t=_correct(tt,shapex._mshape) + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) + } + } + } + nodes=nodes_for_grid(local_region.dist,dest_range) + var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) + foreach pp in #nodes { + p=nodes[pp] + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0 { + b[pp]={ + _getref(_import_dref%(x),h):h in portion_to_recv + } + _isend(i,b[pp]) + } + } + } + } + _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ indexed or shared ] ... +proc _get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) { + t=_correct(tt,shapex._mshape) + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + nodes=nodes_for_grid(local_region.dist,dest_range) + var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) + foreach pp in #nodes { + p=nodes[pp] + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0 { + b[pp]={ + _getref(_import_dref%(x),h):h in portion_to_recv + } + _isend(i,b[pp]) + } + } + } + } + _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0{ + PM__head_node{ + _recv_slice_sync(i,&a,portion_to_recv) + } + if at:_bcast_slice_shared(&a,portion_to_recv) + } + } + } + } + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ priv ] +proc _get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:indexed,complt,at) { + dest_range=_dmap(t,this_tile,#shapex._mshape) + foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt) + } + } + src_range=_dunmap(t,shapex._tile,local_region._mshape) + forall j in overlap(this_tile,src_range) { + jj=index(#this_tile,j) + PM__do_at size(this_tile),jj,aa,a,xx,x { + PM__assign(&aa,_getref(xx,null)) + } + } + foreach p in nodes_for_grid(local_region.dist,src_range) { + if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() { + PM__recv_req pp,xx,x,_getref(xx,null) + } + } + if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt) + } + } + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ whatever ] = priv +proc _set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed, pr:invar proc,complt:invar,at:invar) PM__node <>:_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at) +proc _set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed, pr:proc,complt,at) { + t=_correct(tt,shapex._mshape) + dest_range=_dmap(t,this_tile,#shapex._mshape) + PM__head_node{ + foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(shapex.dist),p) + if contains(#(shapex.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt) + } + } + } + src_range=_dunmap(t,shapex._tile,local_region._mshape) + for j in overlap(this_tile,src_range) { + jj=index(#this_tile,j) + PM__do_at size(this_tile),jj,yy,y,xx,x { + PM__assign(&^(_getlhs(xx,null)),yy,pr) + } + } + foreach p in nodes_for_grid(local_region.dist,src_range) { + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + PM__recv_assn pp,xx,yy,x,y,at{ + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } + } + } + _sync_messages(x,y) +} + +// ************************************************************** +// Envelope and stencil definitions +// ************************************************************** +type envelope is rec{cross:extent or null,corner:extent or null,envelope:extent} +proc ortho(x:extent)=new envelope { + cross=x,corner=spread(0..0,x),envelope=x +} +proc ortho(x:extent,y:extent)=new envelope { + cross=if(x inc y=>x,y),corner=y,envelope=envelope(x,y) +} +proc envelope(x:envelope)=x.envelope +proc envelope(x:extent)=x +proc envelope(x:any_int,y:any_int)=min(xx,yy)..max(xx,yy) where xx=int(x),yy=int(y) +proc envelope(x:any_int,y:seq(any_int))=envelope(x..x,y) +proc envelope(x:seq(any_int),y:any_int)=envelope(x,y..y) +proc envelope(x:seq(any_int),y:seq(any_int))=if(size(x)>0=>if(size(y)>0=>min(lx,ly)..max(hx,hy),lx..hx),if(size(y)>0=>0..0,ly..hy)) where lx=min(llx,hhx),ly=min(lly,hhy),hx=max(llx,hhx),hy=max(lly,hhy)where llx=int(low(x)),lly=int(low(y)),hhx=int(high(x)),hhy=int(high(y)) +proc envelope(x:tuple,y:tuple)=map($envelope,x,y) +proc envelope(x:null,y:extent)=y +proc envelope(x:extent,y:null)=x +proc envelope(x:extent or null,y:envelope)=envelope(x,y.envelope) +proc envelope(x:envelope,y:extent or null)=envelope(x.envelope,y) +proc envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope) +proc string(x:envelope)=string(x.cross++" ortho "++x.corner) +// ************************************************************** +// Support for nhd statement +// ************************************************************** +type _nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits} +type nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here} +proc PM__nhd%(x:invar envelope or extent,bound:invar) shared <>=new _nhd { +_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),_limits=_expand_limits(region._extent,envelope(x),bound)} where t=_get_halo(region,region._tile,envelope(x)) +proc PM__nhd%(x,bound:invar)=^(new _nhd { + _nbhd=n,_tile=t,_tilesz=#t,_interior=t,_limits=region._extent +} +,shared) where t=region._tile where n=xx where xx=spread(0..0,here){ + _check_nhd%(x) +} +proc _check_nhd%(n:invar envelope or extent) { +} +proc _check_nhd%(n:extent):test "Neighbourhood must be invar"=>fix(false) +proc _check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>fix(false) +proc PM__check_bounds%(b:invar boundary){ + _check_ranks(extent(region),b) +} +proc PM__check_bounds%(b:boundary):test "Bounds must be ""invar"""=>fix(false) +proc PM__check_bounds%(b):test "Bounds must have a boundary type"=>fix(false) +proc _check_ranks(n:tuple,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b)) +proc _check_ranks(n:envelope,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n.cross),rank(b)) +proc _check_ranks(n,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(fix(1),rank(b)) +proc _check_ranks(n,b){ +} +type boundary is boundary_dim,tuple(boundary_dim) +type boundary_dim is CYCLE,EXCLUDED,range(int),null +type CYCLE is unique +type EXCLUDED is unique +proc _expand_limits(t:range(int),n:range(int),b:boundary_dim)=t +proc _expand_limits(t:range(int),n:range(int),b:CYCLE)=_exterior(t,n) +proc _expand_limits(t:tuple,n:tuple,b:boundary_dim)=map($_expand_limits,t,n,spread(b,n)) +proc _expand_limits(t:tuple,n:tuple,b:tuple(boundary_dim))=map($_expand_limits,t,n,b) +proc PM__set_nhd%(&n,x:complete){ + n._array[n._nbhd._interior[n._index]]=x +} +proc PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]=x check "Expression in ""nhd"" must be ""complete"""=>fix(false) +proc PM__nhd_join(x)=x._array +proc PM__nhd_join(x,y)=new _join{ + head=x,tail=y._array +} +proc PM__nhd_var%(x,n:_nhd,i,h)<>=new nbhd{ + _array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h +} +proc PM__nhd_active(region,nbhd,bound:null)=region._extent +proc PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound) +proc PM__nhd_active(region,nbhd,bound){ + r=PM__nhd_active(region,nbhd,spread(bound,region._extent)) + return r +} +proc _nhd_active(r,n,b:CYCLE or null)=r +proc _nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b)) +proc _nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n) +proc _make_nhd%(x:invar,d:invar) shared <>{ + var v=array(x,d) + return v +} +proc PM__set_edge%(&x,y,z){ +} +proc PM__subref(x:nbhd,t:subs)=_nhd_sub(x,t) +proc PM__subref(x:nbhd,t:null)=_nhd_sub(x,t) +proc _nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))=PM__subref(x._array,tt+x._nbhd._interior[x._index]) { + tt=_tup(t) + test "Subscript"++tt++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),"At "++x._here++" nhd "++tt++" goes outside of boundary "++limits=>contains(limits,dtt) where limits=x._nbhd._limits where dtt=tt+x._here +} + +proc _nhd_sub(x:nbhd,t)=_arb(x._array)check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>fix(false) +proc PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>fix(false) +proc envelope(x:_nhd)=envelope(x._nbhd) +proc envelope(x,y:_nhd)=envelope(x,y._nbhd) +proc envelope(x:_nhd,y:_nhd)=envelope(x._nbhd,y._nbhd) +type _join is struct^{head,tail} +proc PM__blocking%(x:null){ +} +proc PM__blocking%(x):test "Block expression must be tuple of integers"=>fix(false) +proc PM__blocking%(x:tuple(any_int)){ + test "Rank of ""block="" does not match region"=>same_type(rank(x),rank(region)) + test "Block sizes must be positive"=>map_reduce($_positive,$and,x) +} +proc _positive(x)=x>0 +proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) + ov=this_tile_x#intersect(tile_x,other_tile) + if size(ov)>0 { + _recv_slice(p,&a,ov) + } + } + } + foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) + ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) + if size(ov)>0 { + _send_slice(p,a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(false)) + } +} + +proc PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) + ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) + if size(ov)>0 { + _send_slice(p,a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(false)) + } +} + +proc inside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo..lo-y,hi-y..hi)) where lo=low(x),hi=high(x) +proc inside_edge(x:extent,y:tuple(int))=map($inside_edge,x,y) +proc outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y)) where lo=low(x),hi=high(x) +proc outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y) +proc _foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner) +proc _foot(d,n:extent)=n +proc PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { + PM__head_node{ + _apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(true)) + } +} + +proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) + ov=this_tile_x#intersect(tile_x,other_tile) + if size(ov)>0 { + _recv_slice_sync(p,&a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),region._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(true)) + } +} + +proc PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { + if shrd_nnode()>1 { + foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 { + chunk=chunk(region,envelope(nbhd._nbhd),i,b) + _bcast_slice_shared(&a,chunk) + } + } +} + +proc _rev(a:tuple)=map($_rev,a) +proc _rev(a:range)=-high(a)..-low(a) +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index,recv) { + _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,get_dim(bound,index),index,recv) + _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index-fix(1),recv) +} + +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index:fix(0),recv) { +} +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index,recv) { +} +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:CYCLE,index,recv) { + ex=get_dim(extent,index) + ev=get_dim(envelope,index) + lo=low(ex) + hi=high(ex) + up=max(high(ev),0) + down=min(low(ev),0) + upper_outside=replace(extent,index,hi+1..hi+up) + upper_inside=replace(extent,index,hi+down+1..hi) + lower_outside=replace(extent,index,lo+down..lo-1) + lower_inside=replace(extent,index,lo..lo+up-1) + _copy_bounds(&a,d,n,this_tile_x,upper_outside,lower_inside,recv) + _copy_bounds(&a,d,n,this_tile_x,lower_outside,upper_inside,recv) +} + +proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:fix(false)) { + oldpart,oldtile=overlap(from,d._tile) + newpart,newtile=overlap(to,this_tile_x) + foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(to,overlap(from,element(d.dist,p))) + ov=overlap(this_tile_x,tile) + if size(ov)>0{ + _recv_slice(p,&a,ov) + } + } + } + foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) + ov=this_tile_x#intersect(d._tile,tile) + if size(ov)>0{ + _send_slice(p,a,ov) + } + } + } +} + +proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:fix(false)) { + oldpart,oldtile=overlap(from,d._tile) + newpart,newtile=overlap(to,this_tile_x) + foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) + ov=this_tile_x#intersect(d._tile,tile) + if size(ov)>0{ + _send_slice(p,a,ov) + } + } + } +} + +proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:fix(true)) { + oldpart,oldtile=overlap(from,this_tile_x) + newpart,newtile=overlap(to,this_tile_x) + o,oo=overlap(newpart,oldpart) + _set_slice(&a,element(newtile,o),a,element(oldtile,oo)) +} +proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:fix(true)) { + oldpart,oldtile=overlap(from,this_tile_x) + newpart,newtile=overlap(to,this_tile_x) + o,oo=overlap(newpart,oldpart) + _set_slice(&a,element(newtile,o),a, element(oldtile,oo)) + foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(to,overlap(from,element(d.dist,p))) + _recv_slice(p,&a,overlap(this_tile_x,tile)) + } + } +} + +proc _send_slice(p,a:_join,o) { + _send_slice(p,a.head,o) + _send_slice(p,a.tail,o) +} +proc _recv_slice(p,&a:_join,o) { + _recv_slice(p,&a.head,o) + _recv_slice(p,&a.tail,o) +} +proc _recv_slice_sync(p,&a:_join,o){ + _recv_slice_sync(p,&a.head,o) + _recv_slice_sync(p,&a.tail,o) +} +proc _bcast_slice_shared(&a:_join,o) { + _bcast_slice_shared(&a.head,o) + _bcast_slice_shared(&a.tail,o) +} +proc _sync_messages(x:_join):_sync_messages(x.head,x.tail) +proc _not_zero(x)=if(x/=0=>1,0) +proc _crss(x)=1==map_reduce($_not_zero,$+,x) +// Add (anti) halo around tile +// Args: mshape / tile / displacement +// (mshape not used at the moment - there to cope with other topologies) +// Result: expanded tile +proc _get_halo(d:range(int),t:range(int),i:any_int)=low(t)+ii..high(t)+ii where ii=int(i) +proc _get_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)+ii..high(t)+ii by step(t) where ii=int(i) +proc _get_halo(d:range(int),t:block_seq,i:any_int){ + return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i) +} +proc _get_halo(d:range(int),t:map_seq,i:any_int) { + var a=array(0,size(t)) + for j in a,k in t.array:j=k+i + return new map_seq { + array=a + } +} +proc _get_halo(d:range(int),t:range(int),i:range(any_int))=low(t)+int(low(i))..high(t)+int(high(i)) +proc _get_halo(d:range(int),t:strided_range(int),i:range(any_int)){ + var step=step(t) + var width=size(i) + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) +} +proc _get_halo(d:range(int),t:block_seq,i:range(any_int)){ + var step=step(t) + var width=size(i)+width(t)-1 + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) +} +proc _get_halo(d:range(int),t:map_seq,i:range(any_int)) { + var a=array(0,[0..size(t)*size(i)-1]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + return _redim(a,shape(m)) +} +proc _get_halo(d:extent,j:grid,i:tuple(any_int or range(any_int)))= map($_get_halo,d,j,i) +proc _get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_halo(d.1,t.1,i) +proc _get_halo(d,t,i:null)=t +proc _get_anti_halo(d:range(int),t:range(int),i:any_int)=low(t)-ii..high(t)-ii where ii=int(i) +proc _get_anti_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)-ii..high(t)-ii by step(t) where ii=int(i) +proc _get_anti_halo(d:range(int),t:block_seq,i:any_int){ + return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i) +} +proc _get_anti_halo(d:range(int),t:map_seq,i:any_int) { + var a=array(0,size(t)) + for j in a,k in t.array:j=k-i + return new map_seq { + array=a + } +} +proc _get_anti_halo(d:range(int),t:range(int),i:range(any_int))=low(t)-int(high(i))..high(t)-int(low(i)) +proc _get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){ + var step=step(t) + var width=size(i) + if width>step { + step=1 + width=1 + } + return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width) +} +proc _get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){ + var step=step(t) + var width=size(i)+width(t)-1 + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width) +} +proc _get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) { + var a=array(0,[0..size(t)*size(i)-1]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,-high(i),-low(i)) + return _redim(a,shape(m)) +} +proc _get_anti_halo(d:extent,j:grid, i:tuple(any_int or range(any_int)))= map($_get_anti_halo,d,j,i) +proc _get_anti_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_anti_halo(d.1,t.1,i) +proc _get_anti_halo(d,t,i:null)=t +proc _interior(t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n)) +proc _interior(t:strided_range,n:range)=1..0 by 1 +proc _interior(tt:block_seq,n:range)=block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)where t=middle_blocks(tt) +proc _get_chunk(t:range,n:range,l:fix(true))=low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1) +proc _get_chunk(t:range,n:range,l:fix(false))=low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t) +proc _get_chunk(t:range,n:range,l:_down)=low(t)+w..low(t)+w+w-1 where w=max(0,-low(n)) +proc _get_chunk(t:range,n:range,l:_up)=high(t)-w-w+1..high(t)-w where w=max(0,high(n)) +proc _get_chunk(tt:block_seq,n:range,l:fix(true))=if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t)) where t=middle_blocks(tt) +proc _get_chunk(tt:block_seq,n:range,l:fix(false))=if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t)) where t=middle_blocks(tt) +proc _get_chunk(t:grid_dim,n:range,l:_left or _right)=empty(t) +proc _get_chunk(t:block_seq,n:range,l:_left)=block_seq(low(b),high(b),1,1,0) where b=first_block(t) +proc _get_chunk(t:block_seq,n:range,l:_right)=block_seq(low(b),high(b),1,1,0) where b=last_block(t) +proc _chunk(t,n,r,e,l)=if(r>e=>_interior(t,n),rt,_get_chunk(t,n,l)) +proc _get_chunk(t:tuple1d,n,e,l)=[_chunk(t.1,n.1,1,e,l)] +proc _get_chunk(t:tuple2d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l)] +proc _get_chunk(t:tuple3d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l)] +proc _get_chunk(t:tuple4d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l)] +proc _get_chunk(t:tuple5d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l)] +proc _get_chunk(t:tuple6d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l)] +proc _get_chunk(t:tuple7d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l),_chunk(t.7,n.7,7,e,l)] +proc chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1 +proc chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1 +proc chunks(t:grid,n:extent)=2 +proc _cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n +proc chunk(t:tuple(range(any_int)),n:extent,i:int) { + _cr(i,rank(t)*2) + var r=n + if i==0: r=map($_interior,t,n) elseif i&1==0: r=_get_chunk(t,n,(i+1)/2,fix(true)) else: r=_get_chunk(t,n,(i+1)/2,fix(false)) + return r +} + +type _left is unique +type _right is unique +type _up is unique +type _down is unique +proc chunk(t:tuple(range(any_int) or block_seq),n:extent,i:int) { + _cr(i,rank(t)*4) + var r=t + if i==0:r=map($_interior,t,n) else: switch (i-1)&3 { + case 0:r=_get_chunk(t,n,(i+3)/4,fix(true)) + case 1:r=_get_chunk(t,n,(i+3)/4,fix(false)) + case 2:r=_get_chunk(t,n,(i+3)/4,_left) + default:r=_get_chunk(t,n,(i+3)/4,_right) + } + return r +} +proc chunk(t:grid,n:extent,i:int) { + _cr(i,1) + var r=#t + if i==0:r=empty(#t) + return r +} +proc chunk(t:grid,n:extent,i:int,b:null)=chunk(t,n,i) +proc chunk(t:grid,n:extent,i:int,b:extent)=intersect(chunk(t,n,i),b) +proc inside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix(bool))=_get_chunk(t,n,i,low) +proc outside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix(bool))=_get_chunk(map($_exterior,t,n),n,i,low) +proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:fix(true))=_get_chunk(map($_exterior,t,n),n,i,_up) +proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:fix(false))=_get_chunk(map($_exterior,t,n),n,i,_down) +proc _exterior(t:range(int),n:range(int))=low(t)+min(low(n),0)..high(t)+max(high(n),0) +proc _get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) { + var r=t + tt=map($_exterior,t,n) + if i==0: r=#tt elseif i&1==0: r=_get_chunk(tt,n,(i+1)/2,_up) else: r=_get_chunk(tt,n,(i+1)/2,_down) + return r +} + +// ************************************************************* +// nbr% and nbhd% intrinsics +// ************************************************************* +type disp_index is any_int,tuple(any_int) +type disp_sub is disp_index,tuple(any_int or range(any_int)) +// *** Default *** +proc nbr%(x:chan,t:shared disp_index,v:shared){ + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + j=displace(region._mshape,here,t) + var y=v + if contains(region._mshape,j) { + y=x![j] + } + return y +} + +proc nbhd%(x:chan,t:shared disp_sub,v:shared) { + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + var a=array(v,#t) + foreach invar i in t { + j=displace(region._mshape,here,i) + if j in region._mshape { + a[here]=x![j] + } + } + return a +} + +// *** Blocked distributions *** +proc nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) { + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + var j=displace(region._mshape,here,t) + a,ad=tile_with_halo%(x,t,v) + return a[ad#j] +} + +proc nbhd%(region:dshape(,blocked_distr),x:chan,t:shared disp_sub,v:shared){ + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + a=displace(region._mshape,here,t) + y,yd=tile_with_halo%(x,t,v) + return y[yd#a] +} + +proc tile_with_halo%(x,t,v) { + return a,d where a,d=_local_tile_with_halo(region,PM__local(x),t,v) +} +// Return local tile with halo cells +proc _local_tile_with_halo(region,x,t,v) { + this_tile_x=_get_halo(region._mshape,region._tile,t) + var a=array(v,#this_tile_x) + foreach i in nodes_for_grid(region.dist,this_tile_x) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + var p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _recv_slice(p,&a,overlap(this_tile_x,other_tile)) + } + } + foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _send_slice(p,x,overlap(region._tile,other_tile_x)) + } + } + o,oo=overlap(this_tile_x,region._tile) + a[o]=x[oo] + _sync_messages(a,x) + return a,this_tile_x +} + +proc _local_tile_with_halo(region,x:_comp,t,v) { + this_tile_x=_get_halo(region._mshape,region._tile,t) + var a=array(v,#this_tile_x) + foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _send_slice(p,x,overlap(region._tile,other_tile_x)) + } + } + o,oo=overlap(this_tile_x,region._tile) + a[o]=x[oo] + foreach i in nodes_for_grid(region.dist,this_tile_x) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(dims(region.dist),i) and p/=_this_node() { + _recv_slice_sync(p,&a,overlap(this_tile_x,other_tile)) + } + } + _sync_messages(a,x) + return a,this_tile_x +} + +// Displace x by y within mshape d +proc displace(d:range(int),x:int,y:any_int)=x+int(y) +proc displace(d:range(int),x:int,y:range(any_int))=x+int(y._lo)..x+int(y._hi) +proc displace(d:extent1d,x:tuple1d(int),y:range(any_int) or any_int)=displace(d.1,x.1,y) +proc displace(d:extent,x:tuple(int),y:tuple(range(any_int) or any_int))=map($displace,d,x,y) +// ************************************************ +// TOPOLOGIES +// ************************************************ +proc topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l) +proc topology(tp,dis,d,l:int)=tp +PM__intrinsic<> _get_dims(int,int)->(int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int)->(int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int)->(int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int)->(int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int)->(int,int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int,int)->(int,int,int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "get_dims" +proc _zd(x,y)=if(x==1=>1,nodes_needed(y,x)) +proc cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,spread(VBLOCK,dd),n) +proc cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n) +proc cart_topo(d:tuple1d,t:tuple1d,n:int)=tuple(_get_dims(n,_zd(d.1,t.1))) +proc cart_topo(d:tuple2d,t:tuple2d,n:int)=tuple(b,a) where a,b=_get_dims(n,_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple3d,t:tuple3d,n:int)=tuple(c,b,a) where a,b,c=_get_dims(n,_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple4d,t:tuple4d,n:int)=tuple(dd,c,b,a) where a,b,c,dd=_get_dims(n,_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple5d,t:tuple5d,n:int)=tuple(e,dd,c,b,a) where a,b,c,dd,e=_get_dims(n,_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple6d,t:tuple6d,n:int)=tuple(f,e,dd,c,b,a) where a,b,c,dd,e,f=_get_dims(n,_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple7d,t:tuple7d,n:int)=tuple(g,f,e,dd,c,b,a) where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +// ************************************************ +// DISTRIBUTIONS +// ************************************************ +type distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr +type distr:iterable is null,blocked_distr,distr_dim,tuple(distr_dim),sliced_distr +type blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr) +type distr_template is null,distr_template_dim,tuple(distr_template_dim),... +type distr_template_dim is null,vblock_template,direct_template,block_template,cyclic_template,block_cyclic_template,... +// Null distribution (mirroring) +proc distribute(dis:null,d:int,t:int,p:int)=no_distr(d,t,p) +type no_distr is rec {_hi:int,_p:int,_pr:int} +proc nodes_needed(d:null,g:int)=1 +proc no_distr(g:int,d:int,p:int)=new no_distr { + _hi=int(g),_p=int(d),_pr=p +} +proc #(b:no_distr)=shape([0..b._p-1]) +proc _shp(b:no_distr)=0..b._p-1 +proc dims(b:no_distr)=[b._p] +proc size(b:no_distr)=b._p +proc element(b:no_distr,i:int)=0..b._hi-1 +proc tile_size(b:no_distr,i:int)=b._hi +proc empty(b:no_distr)=1..0 +proc nodes_for_grid(b:no_distr,g:seq(int))=b._pr..b._pr +proc node_for(b:no_distr,j:int)=b._pr +proc index(b:no_distr,j:int,p:int)=j +proc node_nhd(b:no_distr,p:int,d:range(int))=p..p +proc node_co_nhd(b:no_distr,p:int,d:range(int))=p..p +// Direct distribution (1-1 map to processor topology) +type direct_distr is rec {_p:int} +type direct_template is unique{DIRECT} +proc distribute(dis:direct_template,d:int,t:int,p:int)=direct_distr(d) +proc nodes_needed(d:direct_template,g:int)=g +proc direct_distr(d:int)=new direct_distr { + _p=int(d) +} +proc #(b:direct_distr)=shape([0..b._p-1]) +proc _shp(b:direct_distr)=0..b._p-1 +proc dims(b:direct_distr)=[b._p] +proc size(b:direct_distr)=b._p +proc element(b:direct_distr,i:int)=fix(0)..fix(0) +proc tile_size(b:direct_distr,i:int)=fix(1) +proc empty(b:direct_distr)=fix(1)..fix(0) +proc nodes_for_grid(b:direct_distr,g:seq(int))=int(g) +proc node_for(b:direct_distr,j:int)=j +proc index(b:direct_distr,j:int,p:int)=fix(0) +proc node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p +proc node_co_nhd(b:direct_distr,p:int,d:int or range(int))=-low(d)+p..-high(d)+p by -1 +// Variable block distribution +type vblock_distr is rec {_hi:int,_p:int} +type vblock_template is unique{VBLOCK} +proc distribute(dis:vblock_template,d:int,t:int,p:int)=vblock_distr(d,t) +proc nodes_needed(d:vblock_template,g:int)=0 +proc vblock_distr(g:int,d:int)=new vblock_distr { + _hi=int(g),_p=int(d) +} +proc #(b:vblock_distr)=shape([0..b._p-1]) +proc _shp(b:vblock_distr)=0..b._p-1 +proc dims(b:vblock_distr)=[b._p] +proc size(b:vblock_distr)=b._p +proc element(b:vblock_distr,i:int)=start..finish where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) +proc tile_size(b:vblock_distr,i:int)=finish-start+1 where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) +proc empty(b:vblock_distr)=1..0 +proc nodes_for_grid(b:vblock_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(b._p*(low(g)+1)-1,b._hi), hi1=_rdiv(b._p*(high(g)+1)-1,b._hi) +proc node_for(b:vblock_distr,j:int)=p where p=_rdiv(b._p*(j+1)-1,b._hi) +proc index(b:vblock_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._hi/b._p where jj=int(j) +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) +proc node_nhd(b:vblock_distr,p:int,d:range(int))=p+(low(d)-bk+1)/bk..p+(high(d)+bk-1)/bk where bk=b._hi/b._p +// fixed block distribution +type block_distr is rec {_b:int,_s:int,_p:int} +type _block_template is rec{block:int} +type _block_template_default is unique{BLOCK} +type block_template is _block_template_default,_block_template +proc BLOCK(block:int)=new _block_template { + block=block +} +proc distribute(dis:_block_template,d:int,t:int,p:int)=block_distr(d,t,dis.block) +proc distribute(dis:block_template,d:int,t:int,p:int)=block_distr(d,t) +proc nodes_needed(d:_block_template,g:int)=(g+d.block)/d.block +proc nodes_needed(d:block_template,g:int)=0 +proc block_distr(s:int,p:int)=new block_distr { +_b=b,_s=s,_p=p} where b=(s+p-1)/p +proc block_distr(s:int,t:int,b:int)=new block_distr { +_b=b,_s=s,_p=p} where p=(s+b-1)/b +proc #(b:block_distr)=shape([0..b._p-1]) +proc _shp(b:block_distr)=0..b._p-1 +proc dims(b:block_distr)=[b._p] +proc size(b:block_distr)=b._p +proc element(b:block_distr,i:int)=start..finish where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) +proc tile_size(b:block_distr,i:int)=finish-start+1 where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) +proc empty(b:block_distr)=1..0 +proc nodes_for_grid(b:block_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(int(low(g)),b._b), hi1=_rdiv(int(high(g)),b._b) +proc node_for(b:block_distr,j:int)=p where p=_rdiv(jj,b._b) where jj=int(j) +proc index(b:block_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._b where jj=int(j) +proc node_nhd(b:block_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b +// Cyclic distribution +type cyclic_distr is rec {_hi:int,_p:int} +type cyclic_template is unique{CYCLIC} +proc distribute(dis:cyclic_template,d:int,t:int,p:int)=cyclic_distr(d,t) +proc nodes_needed(d:cyclic_template,g:int)=0 +proc cyclic_distr(g:int,d:int)=new cyclic_distr { + _hi=int(g),_p=int(d) +} +proc #(b:cyclic_distr)=shape([0..b._p-1]) +proc _shp(b:cyclic_distr)=0..b._p-1 +proc dims(b:cyclic_distr)=[b._p] +proc size(b:cyclic_distr)=b._p +proc element(b:cyclic_distr,i:int)= int(i)..b._hi-1 by b._p +proc tile_size(b:cyclic_distr,i:int)=(b._hi-1-int(i))/b._p+1 +proc empty(b:cyclic_distr)=1..0 by 1 +proc nodes_for_grid(b:cyclic_distr,g:seq(int))=cyclic_range(lo,high,p) where high=if(hi-lo>=p=>lo+p-1,hi+if(hi>lo=>0,p)) where lo=low(g) mod p,hi=high(g) mod p where p=b._p +proc node_for(b:cyclic_distr,j:any_int)=p where p=int(j) mod b._p +proc index(b:cyclic_distr,j:int,p:int)=int(j)/b._p +proc node_nhd(b:cyclic_distr,p:int,d:range(int))=cyclic_range(p+low(d),p+high(d),b._p) +// Block cyclic distribution +type block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int} +type block_cyclic_template is rec {block:int} +proc BLOCK_CYCLIC(block:int)=new block_cyclic_template{ + block=block +} +proc distribute(dis:block_cyclic_template,d:int,t:int,p:int)=block_cyclic_distr(d,t,dis.block) +proc nodes_needed(d:block_cyclic_template,g:int)=0 +proc block_cyclic_distr(g:int,p:int,b:int)=new block_cyclic_distr { +_hi=int(g),_p=int(pp),_b=bb, _s=s} where s=pp*bb where bb=if(pp==1=>g,b) where pp=min((g+b-1)/b,p) +proc #(b:block_cyclic_distr)=shape([0..b._p-1]) +proc _shp(b:block_cyclic_distr)=0..b._p-1 +proc dims(b:block_cyclic_distr)=[b._p] +proc size(b:block_cyclic_distr)=b._p +proc element(b:block_cyclic_distr,i:int)= block_seq(s,b._hi-1,b._s,b._b,0) where s=ii*b._b where ii=int(i) +proc tile_size(b:block_cyclic_distr,i:int)=nc*b._b+max(0,min(b._b,df-nc*b._s)) where nc=df/b._s where df=b._hi-s where s=ii*b._b where ii=int(i) +proc empty(b:block_cyclic_distr)=block_seq(1,0,1,1,0) +proc nodes_for_grid(b:block_cyclic_distr,g:grid_dim)=if(hi-lo+1cyclic_range(lo,hi,p),cyclic_range(0,p-1,p)) where lo=low(g)/b._b,hi=high(g)/b._b where p=b._p +proc nodes_for_grid(b:block_cyclic_distr,g:strided_range){ + var r=0..0 + if b._s==step(g) { + r=nodes_for_grid(b,low(g)..low(g))} else { + r=nodes_for_grid(b,low(g)..high(g)) + } + return r +} + +proc nodes_for_grid(b:block_cyclic_distr,g:block_seq){ + var r=cyclic_range(0,0,1) + if b._s==step(g) { + r=nodes_for_grid(b,low(g)..low(g)+width(g)-1)} else { + r=nodes_for_grid(b,low(g)..high(g)) + } + return r +} + +proc node_for(b:block_cyclic_distr,j:int)=p where p=_rdiv(jj,b._b) mod b._p where jj=int(j) +proc index(b:block_cyclic_distr,j:int,p:int)=i where i=r+b._b*(s-p) where r=j-s*b._s where s=_rdiv(j,b._s) +proc node_nhd(b:block_cyclic_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b +proc nodes_for_grid(b,g:single_point)=nodes_for_grid(b,g._t..g._t) +// Tuple of distributions +proc distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))=map($distribute,dis,d,t,p) where p=index2point(_this_node(),t) +proc distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))=map($distribute,spread(dis,d),d,t,p) where p=index2point(_this_node(),t) +proc distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t) +proc nodes_needed(b:tuple(distr_template_dim),g:tuple(int))=map($nodes_needed,b,g) +proc nodes_needed(b:distr_template_dim,g:tuple(int))=map($nodes_needed,spread(b,g),g) +proc node_for(b:tuple(distr_dim),j:tuple(int))=map($node_for,b,j) +proc #(b:tuple(distr_dim))=shape(map($_shp,b)) +proc dims(b:tuple(distr_dim))=map($size,b) +proc element(b:tuple(distr_dim),i:tuple(int))=map($element,b,i) +proc element(b:tuple(distr_dim),i:int)=element(b,index2point(i,dims(b))) +proc tile_size(b:tuple(distr_dim),i:tuple(int))=map($tile_size,b,i) +proc empty(b:tuple(distr_dim))=map($empty,b) +proc nodes_for_grid(b:tuple(distr_dim),g:grid_slice)=map($nodes_for_grid,b,g) +proc node_num_for(b:tuple(distr_dim),j:tuple(int))=index(dims(b),map($node_for,b,j)) +proc index(b:tuple(distr_dim),j:tuple(int),p:tuple(int))=index(tile_size(b,p),map($index,b,j,p)) +proc node_and_index(b:tuple(distr_dim),j:tuple(int))=index(dims(b),p),i where i=index(tile_size(b,p),map($index,b,j,p)) where p=map($node_for,b,j) +proc node_and_index(b:distr_dim,j:int)=p,i where i=index(b,j,p) where p=node_for(b,j) +proc node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d) +proc node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d) +// Slice of a tuple of distributions +type sliced_distr(t,s) is rec{_t:t,_s:s} +proc sliced_distr(t:tuple(distr_dim),s:tuple(seq(int) or single_point(int)))=new sliced_distr{ + _t=t,_s=s +} +proc node_for(t:sliced_distr,j:tuple(int))=node_for(t._t,t._s[j]) +proc #(t:sliced_distr)=#t._t +proc dims(t:sliced_distr)=dims(t._t) +proc element(t:sliced_distr,i:tuple(int) or int)=overlap(t._s,element(t._t,i)) +proc tile_size(t:sliced_distr,i:tuple(int) or int)=dims(element(t,i)) +proc empty(t:sliced_distr)=new sliced_distr{ + _t=empty(t._t),_s=t._s +} +proc nodes_for_grid(t:sliced_distr,g:grid)=nodes_for_grid(t._t,t._s[g]) +proc node_num_for(t:sliced_distr,j:tuple(int))=node_num_for(t._t,t._s[j]) +proc index(t:sliced_distr,j:tuple(int),p:tuple(int))=index(tile_size(t,p),element(t,p)#j) +proc node_and_index(t:sliced_distr,j:int)=p,i where i=index(t,j,p) where p=node_for(t,j) +proc node_nhd(t:sliced_distr,p:tuple,d:tuple)=node_nhd(t._t,p,_stpmult(d,t._s)) +proc node_co_nhd(t:sliced_distr,p:tuple,d:tuple)=node_co_nhd(t._t,p,_stpmult(d,t._s)) +proc _stpmult(d:tuple,s:tuple)=map($_stpmult,d,s) +proc _stpmult(d:range,s:range)=d +proc _stpmult(d:range,s:strided_range)=if(st>0=>st*low(d)..st*high(d),st*high(d)..st*low(d)) where st=step(s) +// ***************************************** +// SUPPORT FOR PARALLEL STATEMENTS +// ***************************************** +// Get and set elements in "for" +proc PM__getelem(x:grid_slice_dim or cyclic_range,y)=element(x,y) +proc PM__getelem(x:grid_slice or iterable_grid,y)=element(x,y) +proc PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t)) +proc PM__getelem(a:array_slice(any^any,),y)=element(a,y) +proc PM__getelem(x:array_template,y)=x._a +proc PM__getelem(a:any^dshape,t)=element(a,(#a)[t]) +proc PM__setelem(&x,v,y) { + _set_elem(&x,v,(#x)[y]) +} +proc PM__setelem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(dims(a),t),v) +} + +proc PM__setelem(&a:any^dshape,v,t:index) { + PM__setaelem(&a,i,v) check p==_this_node() where p,i=node_and_index((#a).dist,_tup(t)) +} + +proc PM__setelem(&a:array_slice(any^any,),v,t:index) { + _set_elem(&a._a,v,a._s[t]) +} + +proc PM__get_elem%(x,i,h)=PM__getelem(x,h) +proc PM__set_elem%(&x:invar,v:complete,i,h){ + PM__setelem(&x,v,h <>) + _assemble%(&x,region) +} +proc PM__get_elem%(x:shared any^dshape,i,h)=element(PM__local(x),i) +proc PM__set_elem%(&x:invar any^dshape,v:complete,i,h) { + _set_elem(&^(PM__local(^(&x))),v,i <>) +} +proc PM__get_elem%(x:shared array_slice(any^dshape),j,h)=_get_aelem(x._a,i) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +proc PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){ + PM__setaelem(&x._a,i,v <>) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +} + +proc _assemble%(&a:invar any^mshape,xregion:invar mshape) { +} +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) { +} +proc _assemble%(&a:invar any^mshape,xregion:invar) shared <> { + dist=xregion.dist + foreach p in #(dist) { + tile=dist[p] + i=index(dims(dist),p) + if i==_this_node() { + forall j in tile { + var k=PM__getelem(a,j) + PM__broadcast(&k,i) + } + } else { + forall j in tile { + var k=_arb(a) + PM__broadcast(&k,i) + PM__setelem(&a,k,j <>) + } + } + } +} + +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> { + dist=xregion.dist + foreach p in #(dist) { + tile=intersect((#(a._a))#a._s,dist[p]) + i=index(dims(dist),p) + if i==_this_node() { + forall j in tile { + var k=PM__getelem(a._a,j) + PM__broadcast(&k,i) + } + } else { + forall j in tile { + var k=_arb(a._a) + PM__broadcast(&k,i) + PM__setelem(&a._a,k,j <>) + } + } + } +} + +// Support for % procs +proc PM__get_tilesz(d)=d._tile,d._size +proc PM__get_tilesz(d:mshape)=d,size(d) +// Support for ! operator +PM__if_compiling +proc PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region)) +proc PM__makearray%(x:priv)=_makearray(x,region,size(region)):test "Can only apply ""!"" to a ""chan"" " => fix(false) +proc PM__makearray%(x:invar)=_makearray(x,region,size(region)):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => fix(false) +PM__intrinsic<> _makearray(x:any,y:any,z:any)->(PM__invar_dim x,y) : "make_array" +PM__else +proc PM__makearray%(x:chan) complete <>=_makearray(x,region) +proc PM__makearray%(x:priv)=_makearray(x,region):test "Can only apply ""!"" to a ""chan"" " => fix(false) +proc PM__makearray%(x:invar)=_makearray(x,region):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => fix(false) +PM__intrinsic<> _makearray(x:any,y:any)->(PM__dim x,y) : "make_array" +PM__endif +// active%() intrinsic +proc active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>) +proc _masked%(x) complete <>=masked(x) +proc active%()=^(^??,coherent) +PM__intrinsic PM__active()->(bool) : "active" +// Imports and exports +PM__intrinsic _import_val(x:any)->(=x) : "import_val" +PM__intrinsic PM__importshrd(x:any)->(=x) : "import_val" +PM__intrinsic<> PM__importvarg(x:any)->(=x) : "import_varg" +PM__intrinsic _import_scalar(x:any)->(invar x) : "import_scalar" +proc PM__import_val(x) { + PM__checkimp(x) + return _import_val(x) +} +proc PM__impscalar(x) { + PM__checkimp(x) + return _import_scalar(x) +} +proc PM__import_val(x:^*(,,,,)) { + test "Compiler internal error:importing reference" => fix(false) + return x +} +proc PM__impscalar(x:^*(,,,,)) { + test "Compiler internal error:importing reference" => fix(false) + return x +} +proc PM__checkimp(x,arg...) { + PM__checkimp(x) + PM__checkimp(arg...) +} +proc PM__checkimp(x) { +} +proc PM__checkimp(x:contains(PM__distr_tag)) { + test "Cannot import a distributed value into a nested parallel scope" => fix(false) +} +type schedule(subregion,blocking) is rec{_subregion:subregion,_subtile,_blocking:blocking} +proc subregion(schedule:schedule)=schedule._subregion +proc subregion(schedule:null)=null +proc subtile(schedule:schedule)=schedule._subtile +// Over statements +proc PM__over%(schedule:null,x:invar,block:invar) shared <>=new schedule{ + _subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region) +} +proc PM__over%(x:invar,block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(x,schedule._subregion) +proc PM__make_over%(schedule:null,x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s where s=fill_in(region._extent,x,null) +proc PM__make_over%(x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(map($norm,fill_in(region._extent,x,fix(true))),schedule._subregion) +proc PM__make_over%(x:invar,block)=x check "Expression in an ""over"" statement must be a subscript tuple"=>fix(false) +proc PM__make_over%(x,block)=x check "Expression in an ""over"" statement must be ""invar"""=>fix(false) +proc _blocking(b:tuple(any_int),region)=int(b) { + test "Blocking factor must have same rank as current region"=> rank(b)==rank(extent(region)) +} + +proc _blocking(b,region)=null { + test "Blocking factor must be a tuple of integers"=>fix(false) +} +proc _blocking(b:null,region)=null +PM__if_compiling +proc PM__do_over(x:null,region)=x +proc PM__do_over(x:schedule,region)=_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking) +proc _do_elem(x:range(int))=_st(low(x),high(x)) +proc _do_elem(x:strided_range(int))=_st(low(x),high(x),step(x)) +proc _do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x)) +proc _do_elem(x:map_seq)=_st(x.array,size(x.array),null,null) +proc _do_elem(x:single_point)=_st(x._t) +proc PM__nested_loop(x:null){ +} +PM__intrinsic PM__nested_loop(any): "nested_loop" +proc _ldims(x:mshape)=map_apply($size,$_st,x._extent) +proc _ldims(x:dshape)=map_apply($size,$_st,x._tile) +PM__else +proc PM__do_over%(x:null)=true +proc PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion +proc PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile) +proc PM__do_over%(x:invar grid) complete <>{ + chan var t=false + _in%(x,&^(PM__local(^(&t!))) <>) + return t +} + +proc PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x +proc _in%(x:invar,&t:invar) shared <>{ + forall i in x { + sync t[i]=true + } +} +PM__endif +// Parallel processing inquiry +PM__intrinsic _sys_node()->(int) : "sys_node" +PM__intrinsic sys_nnode()->(int) : "sys_nnode" +PM__intrinsic _this_node()->(int) : "this_node"(1) +PM__intrinsic this_node%(r:any,s:any,h:any)->(int) : "this_node"(2) +PM__intrinsic this_nnode()->(int) : "this_nnode" +PM__intrinsic _shrd_node()->(int) : "shared_node" +PM__intrinsic shrd_nnode()->(int) : "shared_nnode" +PM__intrinsic _root_node()->(int) : "root_node" +PM__intrinsic is_shrd()->(bool) : "is_shared" +PM__intrinsic is_shrd(any)->(bool) : "is_shared" +PM__intrinsic is_par()->(bool) : "is_par" +proc _head_node()=_shrd_node()==0 +// Parallel system nested contexts +PM__intrinsic<> _push_node_grid(arg...:any): "push_node_grid" +proc _push_node(d:int,t:int){ + _push_node_grid(false,t) +} +proc _push_node(d:tuple1d,t:tuple1d,e:tuple1d) { + _push_node_grid(is_cyclic(e.1),t.1) +} + +proc _push_node(d:tuple2d,t:tuple2d,e:tuple2d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),t.1,t.2) +} + +proc _push_node(d:tuple3d,t:tuple3d,e:tuple3d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),t.1,t.2,t.3) +} + +proc _push_node(d:tuple4d,t:tuple4d,e:tuple4d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),t.1,t.2,t.3,t.4) +} + +proc _push_node(d:tuple5d,t:tuple5d,e:tuple5d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),t.1,t.2,t.3,t.4,t.5) +} + +proc _push_node(d:tuple6d,t:tuple6d,e:tuple6d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),t.1,t.2,t.3,t.4,t.5,t.6) +} + +proc _push_node(d:tuple7d,t:tuple7d,e:tuple7) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),t.1,t.2,t.3,t.4,t.5,t.6,t.7) +} + +PM__intrinsic<> _push_node_split(int): "push_node_split" +PM__intrinsic _push_node_conc(): "push_node_conc" +proc PM__pop_node(x:mshape) { +} +PM__intrinsic PM__pop_node(x:shape): "pop_node" +PM__intrinsic PM__pop_conc(bool): "pop_node_conc" +PM__intrinsic<> _push_node_dist(): "push_node_distr" +proc _lvl()=1 +// ************************************************ +// PROCESSOR ALLOCATION +// ************************************************ +proc PM__partition(pp,d:dshape) { + _push_node_dist() + return dd._tile,dd,null where dd=new dshape { + _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} +proc PM__partition(pp,d:dshape,distr:null,topo:null,simplify:null,work:null,sched,block) { + _push_node_dist() + return dd._tile,dd,_block_schedule(block,dd) where dd=new dshape { + _mshape=#d._mshape,dist=d.dist, _tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} + +proc PM__partition(pp,d:dshape,distr,topo,simplify,work,sched,block) { + test "Cannot have attributes in ""for""statement over distributed value" => fix(false) + return dd._tile,dd,null where dd=new dshape { + _mshape=##d,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} +proc PM__partition(pp,d:mshape)=tile,shape,sched where tile,shape,sched= PM__partition(pp,d,null,null,null,null,null,null) +proc PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) { + d=dims(mshape) + topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode())) + var p=_shrd_node() + dist=distribute(distr,d,topol) + s=size(#(dist)) + np=shrd_nnode() + test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np + if s=s { + p=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) + } + _push_node_split(p) } else { + _push_node_dist() + } + elem=element(dist,p) + elemsz=#elem + dd=new dshape { + _mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz, _size=size(elemsz),_level=_lvl() + } + return dd._tile,dd,_block_schedule(block,dd) +} + +proc PM__partition(pp:null,d:mshape,distr,topo,simplify,work,sched,block)=#d._extent,#d,_block_schedule(block,#d) +proc PM__partition(pp:null,d:dshape,distr,topo,simplify,work,sched,block)=#d._extent,#d._mshape,_block_schedule(block,#d._mshape) +proc _block_schedule(block:null,region)=null +proc _block_schedule(block,region)=new schedule{ + _subregion=region,_subtile=region._tile,_blocking=_blocking(block,region) +} +proc workshare(work:null,d,dist,nnode:int,snode:int,nsnode:int)=nnode*(2*snode+1)/(2*nsnode) +proc workshare(work:array(int),d,dist,nnode:int,snode:int,nsnode:int) { + test "work array does not conform to mshape"=>conform(#work,#d) + var wk=work + return _wshare(wk,nnode,snode,nsnode) +} + +PM__intrinsic _wshare(int^any,int,int,int)->(int) : "wshare" +// ************************************************************* +// I/O OPERATIONS +// ************************************************************* +// Built-in operators +PM__intrinsic<> _open_file(string,bool,bool,bool,bool,bool,bool,bool)->(sint,sint) : "open_file" +PM__intrinsic<> _close_file(sint)->(sint) : "close_file" +PM__intrinsic<> _seek_file(sint,lint)->(sint) : "seek_file" +PM__intrinsic<> _read_file(sint,&any)->(sint) : "read_file" +PM__intrinsic<> _write_file(sint,any)->(sint) : "write_file" +PM__intrinsic<> _read_file_array(sint,&any,int)->(sint) : "read_file_array" +PM__intrinsic<> _write_file_array(sint,any,int)->(sint) : "write_file_array" +PM__intrinsic<> _read_file_tile%(any,any,any,sint,&any,int,int)->(sint) : "read_file_tile" +PM__intrinsic<> _write_file_tile%(any,any,any,sint,any,int,int)->(sint) : "write_file_tile" +PM__intrinsic<> _io_error_string(sint)->(string) : "io_error_string" +// IO/related types +type io_type is num,bool +type filesystem is rec{_tag:PM__distr_tag} +type file is struct {_f:sint,_tag:PM__distr_tag} +type io_error is rec {_errno:sint,use _iserr:bool} +proc PM__filesys()=new filesystem{ +} +// Basic operations + +// @@ with no keys... now, need to pass through keywords + +proc open(&filesystem:filesystem,name,append=false,create=false,temp=false,excl=false,read=false,write=false,seq=false)=new file { + _f=f +},_make_file_error(err) where f,err=_open_file(name,append,create,temp,excl,read,write,seq) +proc _make_file_error(x:sint)=new io_error { + _errno=x,_iserr=x/=0 +} +proc close(&f:file){ + err=_close_file(f._f) + return _make_file_error(err) +} +proc seek(&f:file,j:lint){ + err=_seek_file(f._f,j) + return _make_file_error(err) +} +proc read(&f:file,&x:io_type){ + err=_read_file(f._f,&x) + return _make_file_error(err) +} +proc write(&f:file,x:io_type){ + err=_write_file(f._f,x) + return _make_file_error(err) +} +// Array I/O +proc read(&f:file,&x:io_type^mshape){ + err=_read_file_array(f._f,&x,size(x)) + return _make_file_error(err) +} +proc write(&f:file,x:io_type^mshape){ + err=_write_file_array(f._f,x,size(x)) + return _make_file_error(err) +} +proc read(&f:file,&x:io_type^dshape) { + var err=_make_file_error(0fix(s)) + for i in x:err=read%(&f,&i) + return err +} +proc write(&f:file,x:io_type^dshape) { + var err=_make_file_error(0fix(s)) + for i in x:err=write%(&f,i) +} +// Distributed I/O +proc partition%(f:filesystem)=f:test "Partition not yet implemented"=>fix(false) +proc read%(&f:shared file,&x:complete io_type){ + err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape)) + return _make_file_error(err) +} +proc write%(&f:shared file,x:complete io_type){ + err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape)) + return _make_file_error(err) +} +// Error trapping versions of I/O routines +proc string(error:io_error)=_io_error_string(error._errno) +proc open(&f:filesystem,name:string) { + file,error=open(&f,name) + test "Error opening file """++name++""": "++error=>not(error) + return file +} + +proc close(&f:file) { + error=close(&f) + test "Error closing file:"++error=>not(error) +} +proc read(&f:file,&x) { + error=read(&f,&x) + test "Error reading from file:"++error=>not(error) +} +proc write(&f:file,x) { + error=write(&f,x) + test "Error writing to file:"++error=>not(error) +} +proc seek(&f:file,x:lint) { + error=seek(&f,x) + test "Error on seek:"++error=>not(error) +} +proc read%(&f:shared file,&x) { + error=read%(&f,&x) + test "Error reading from file:"++error=>not(error) +} +proc write%(&f:shared file,x) { + error=write%(&f,x) + test "Error writing to file:"=>not(error) +} +// ************************************************************* +// SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS +// ************************************************************* +// SOA tuples +type _stuple1d is rec^{t1} +type _stuple2d is rec^{t1,t2} +type _stuple3d is rec^{t1,t2,t3} +type _stuple4d is rec^{t1,t2,t3,t4} +type _stuple5d is rec^{t1,t2,t3,t4,t5} +type _stuple6d is rec^{t1,t2,t3,t4,t5,t6} +type _stuple7d is rec^{t1,t2,t3,t4,t5,t6,t7} +proc _st(t1)=new _stuple1d{ + t1=t1 +} +proc _st(t1,t2)=new _stuple2d{ + t1=t1,t2=t2 +} +proc _st(t1,t2,t3)=new _stuple3d{ + t1=t1,t2=t2,t3=t3 +} +proc _st(t1,t2,t3,t4)=new _stuple4d{ + t1=t1,t2=t2,t3=t3,t4=t4 +} +proc _st(t1,t2,t3,t4,t5)=new _stuple5d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5 +} +proc _st(t1,t2,t3,t4,t5,t6)=new _stuple6d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 +} +proc _st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7 +} +// Create normalised form of a grid used for _xxx_slice operations +proc _norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x)) +proc _norm(n,x:map_seq)=_st(x.array,n) +proc _norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x)) +// Apply idxdim index and convert to normal for for _send_slice_mapped +proc _dnorm(x:indexed_dim(fix(1)),m,n:single_point)=_st(m,t,t,1,1,0) where t=_dmap(x,n._t) +proc _dnorm(x:indexed_dim(fix(1)),m,n:range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),1,1,0) +proc _dnorm(x:indexed_dim(fix(1)),m,n:strided_range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),x._st*n._m,1,0) +proc _dnorm(x:indexed_dim(fix(1),fix(1)),m,n:block_seq)=_st(m,n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) +proc _dnorm(x:indexed_dim(fix(1)),m,n:block_seq)=_dnorm(x,m,map_seq(n)) +proc _dnorm(x:indexed_dim(fix(1)),m,n:map_seq){ + var a=array(0,#n._array) + forall i in a,j in n._array:i=_dmap(x,j) + return _st(a) +} +proc _dnorm(x:indexed_dim(fix(1)),m,n:grid)=_st(map_apply($_dnorm,$_st,x,m,n),size(n)) +type _griddef is rec^{grid,elems} +proc _gd(grid,elems,size)=new _griddef{ + grid=grid,elems=elems +} +proc _send_slice(p,x:_comp^any,d) { + forall i in d { + _isend_offset%(j,p,x) where j=index(#x,i) + } +} + +proc _send_slice(p,x,d) { + _isend_offset(_norm(dims(x),d),p,x) +} + +proc _send_slice_mapped(p,x,d,t,s) { + forall k in d { + _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) + } +} + +proc _send_slice_mapped(p,x:_comp^any,d,t:indexed_dim(fix(1)),s) { + forall k in d { + _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) + } +} + +proc _send_slice_mapped(p,x,d,t:indexed_dim(fix(1)),s) { + _isend_offset(_dnorm(t,dims(x),d),p,x) +} + +proc _recv_slice(p,&x:_comp^any,d) { + forall i in d { + _irecv_offset%(j,p,&x) where j=index(#x,i) + } +} + +proc _recv_slice(p,&x,d) { + _irecv_offset(_norm(dims(x),d),p,&x) +} + +proc _recv_slice_sync(p,&x:_comp^any,d) { + forall i in d { + _recv_offset%(j,p,&x) where j=index(#x,i) + } +} + +proc _recv_slice_sync(p,&x,d) { + _recv_offset(_norm(dims(x),d),p,&x) +} + +proc _bcast_slice_shared(&x,d){ + _bcast_shared_offset(_norm(dims(x),d),&x) +} +proc _send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^(fix(true))) { + forall i in d { + j=index(sx,i) + _isend_recv_req%(j,p,^(x),&^(^(a))) + } +} + +proc _send_recv_slice_req(p,x,&a,sx,d,c:^^(fix(true))) { + _isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a))) +} +proc _send_recv_slice_req(p,x,&a,sx,d,c) { + forall i in d { + j=index(sx,i) + _isend_recv_req%(j,p,^(x),&^(^(a)),c) + } +} + +proc _send_slice_assn(p,x:_comp,y,sx,d,c:^^(fix(true))) { + forall i in d { + _isend_assn%(j,^(p),^(x),^(y)) where j=index(sx,i) + } +} + +proc _send_slice_assn(p,x,y,sx,d,c:^^(fix(true))) { + _isend_assn(_norm(dims(sx),d),p,x,y) +} +proc _send_slice_assn(p,x,y,sx,d,c) { + forall i in d { + _isend_assn%(j,p,^(x),^(y),^(c)) where j=index(sx,i) + } +} + +proc _recv_slice_reply(p,&x:_comp,sx,d,c:^^(fix(true))) { + forall i in d { + _recv_reply%(j,^(p),&^(^(x))) where j=index(sx,i) + } +} + +proc _recv_slice_reply(p,&x,sx,d,c:^^(fix(true))) { + _recv_reply(_norm(dims(sx),d),p,&x) +} +proc _recv_slice_reply(p,&x,sx,d,c) { + forall i in d { + _recv_reply%(j,p,&^(^(x)),c) where j=index(sx,i) + } +} + +PM__intrinsic<> _isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any): "isend_offset" +PM__intrinsic<> _isend_offset(j:any,p:any,x:any): "isend_grid" +PM__intrinsic<> _irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "irecv_offset" +PM__intrinsic<> _irecv_offset(j:any,p:any,&x:any): "irecv_grid" +PM__intrinsic<> _recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_offset" +PM__intrinsic<> _recv_offset(j:any,p:any,&x:any): "recv_grid" +PM__intrinsic<> _bcast_shared_offset%(r:any,s:any,h:any,j:any,&x:any): "bcast_shared_offset" +PM__intrinsic<> _bcast_shared_offset(j:any,&x:any): "bcast_shared_grid" +PM__intrinsic<> _isend(p:any,x:any): "isend" +PM__intrinsic<> _irecv(p:any,&x:any): "irecv" +PM__intrinsic<> _recv(p:any,&x:any): "recv" +PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any): "isend_req" +PM__intrinsic<> _isend_recv_req(j:any,p:any,x:any,&a:any): "isend_req" +PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any): "isend_req" +PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any): "isend_assn" +PM__intrinsic<> _isend_assn(j:any,p:any,x:any,y:any): "isend_assn" +PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any): "isend_assn" +PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any): "recv_reply" +PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_reply" +PM__intrinsic<> _recv_reply(j:any,p:any,&x:any): "recv_reply" +PM__intrinsic<> _bcast_shared(&x:any): "broadcast_shared" +PM__intrinsic<> _bcast_shared(&x:any,p:int): "broadcast_shared" +type _ct is array_slice,^*(,,,,),any^any,^^(any) +proc PM__sync_messages(x)<>:_sync_messages(x) +PM__if_compiling +proc _sync_messages(x:_ct):_do_sync_messages(_core(x)) +proc _sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y)) +proc _core(x:any^any)=x +proc _core(x:^^(any))=x +proc _core(x:array_slice)=_core(x._a) +proc _core(x:^*(,,,,))=_core(_v2(x)) +PM__intrinsic<> _do_sync_messages(arg...:^^(any) or any^any): "sync_mess" +PM__else +PM__intrinsic<> _sync_messages(arg...:_ct): "sync_mess" +PM__endif +proc _tup(x:tuple)=x +proc _tup(arg...)=tuple(arg...) +proc _tup(x:null)=x +proc _tup%(x:invar) shared=_tup(x) +PM__intrinsic<> PM__broadcast(&b:any,a:int): "broadcast" +PM__intrinsic<> PM__broadcast(b:any,a:int)->(=b) : "broadcast_val" +PM__intrinsic<> get_remote%(r:any,s:any,h:any,a:shared any^dshape,b:int,c:int)->(%a) : "get_remote_distr" +PM__intrinsic<> put_remote%(r:any,s:any,h:any,a:shared any^dshape,b:any,c:int,d:int): "put_remote_distr" +// ******************************************************** +// OTHER COMMUNICATING & ARRAY OPERATIONS +// ******************************************************** +proc map(p:proc,x:any^any) { + var z=array(p.(_arb(x)),#x) + for i in z, j in x:i=p.(j) +} +proc map(p:proc,x:any^any,y:any^any) { + var z=array(p.(_arb(x),_arb(y)),#x) + for i in z,j in x,k in y:i=p.(j,k) +} +proc map(p:proc,x:any^mshape,y:any^dshape) { + var z=array(p.(_arb(x),_arb(y)),#(y)) + for i in z,j in x,k in y:i=p.(j,k) +} +proc map_const(p:proc,x:any^mshape,y:any){ + var z=array(p.(_arb(x),y),#x) + for i in z,j in x:i=p.(j,y) +} +proc +(x:num^any,y:num^any)=map($+,x,y) +proc -(x:num^any,y:num^any)=map($-,x,y) +proc *(x:num^any,y:num^any)=map($*,x,y) +proc /(x:num^any,y:num^any)=map($/,x,y) +proc **(x:num^any,y:num^any)=map($**,x,y) +proc mod(x:real_num^any,y:real_num^any)=map($mod,x,y) +proc max(x:real_num^any,y:real_num^any)=map($max,x,y) +proc min(x:real_num^any,y:real_num^any)=map($min,x,y) +proc +(x:num^any,y:any)=map_const($+,x,y) +proc -(x:num^any,y:any)=map_const($-,x,y) +proc *(x:num^any,y:any)=map_const($*,x,y) +proc /(x:num^any,y:any)=map_const($/,x,y) +proc **(x:num^any,y:any)=map_const($**,x,y) +proc mod(x:real_num^any,y:real_num)=map_const($mod,x,y) +proc max(x:real_num^any,y:real_num)=map_const($max,x,y) +proc min(x:real_num^any,y:real_num)=map_const($min,x,y) +PM__intrinsic _pack(v:any,any,any,d:any)->(PM__dim v,d) : "pack" +proc pack(v:any^mshape,m:bool^mshape) { + test "arrays do not conform"=>conform(#v,#m) + result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) +} + +proc pack(vv:array,mm:array) { + var v=vv + var m=mm + return _pack(v,m,n,tuple(0..n-1)) where n=count(m) +} + +// Reduction +type associative_proc is $+,$*,$max,$min,$&,$|,$xor,$++,$==,... +PM__if_compiling +proc reduce(p:proc,x:array(,mshape)) { + var s=_get_aelem(x,0) + foreach i in 1..size(#x)-1 { + s=p.(s,_get_aelem(x,i)) + } + return s +} +PM__else +proc reduce(p:proc,x:array(,mshape)) { + var y=x + var n=size(x) + while n>1 { + var m=(n+1)/2 + forall k in m..n-1 { + PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>) + } + n=m + } + return _get_aelem(y,0) +} + +PM__endif +proc reduce(p:proc,y:array)=_reduce(p,reduce(p,PM__local(y))) +proc _reduce_for_assign%(p:invar associative_proc,y,init:invar){ + chan yy=y + return reduce%(p,yy,init) +} +proc _reduce_for_assign%(p:invar $-,y,init:invar){ + chan yy=y + return init - _reduce%($+,yy,init) +} +proc _reduce_for_assign%(p:invar $/,y,init:invar){ + chan yy=y + return init / _reduce%($*,yy,init) +} +proc reduce%(p:invar proc,y:chan,init)=^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform) +proc _reduce%(p:invar proc,y:chan)=^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform) +proc _reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y) +proc __reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y) +proc _reduce(p:proc,y) { + var x=array(y,[0..0]) + var z=array(y,[0..0]) + var n=this_nnode() + var i=1 + until i>n-1 { + other=_this_node() xor i + if other=y._lo and x<=y._hi +proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:literal(int),y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x +type _crange is rec{_lo,_hi} +proc PM__caserange(x,y)=x..y +proc PM__caserange(x:fix(int),y:fix(int))=new _crange{ + _lo=x,_hi=y +} + +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:fix(true),y,z)=y +proc PM__if(x:fix(false),y,z)=z +proc PM__if(x:fix(true),y:literal,z)=y +proc PM__if(x:fix(false),y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...)) + +// Assignment +proc PM__assign_or_init(a,b)<>=a { + PM__assign_var(&^(a),b) +} + +proc PM__assign_or_init(a:,b)=PM__dup(b as a) + +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} + +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a +} + +type assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,... + +proc PM__assign(&a:any,b:any,c:assignment_operator) { + PM__assign(&a,c.(a,b)) +} + +proc PM__assign(&a:any,b:any,c:proc) { + test "Not a recognised assignment operator"=>fix(false) +} + +proc check_assign_types(x,y){ + test "Type mismatch in assignment"=>same_type(x,y) +} +proc _assign(&a,b) { + _assign_element(&a,b) +} + +/* +proc _assign(&a:contains(farray),b) { + _assign_structure(&a,b) +} +*/ +proc _assign_structure(&a,b)<>{ + _assign_element(&a,b) +} +proc _assign_structure(&a:farray,b){ + _array_assign(&a,b,fix(true)) +} +PM__intrinsic _assign_element(&any,any): "assign" + + +// Other variable operations +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +proc PM__dup(PM__dup) <>=PM__clone(PM__dup) +PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" +PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" +PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" +PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" +PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" +PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" +proc ==(x:any,y:any) { + test "Cannot apply ""=="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return not ok +} +proc _eq(x:any,y:any,&ok) <> { + ok=ok and x==y +} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) + +PM__intrinsic<> PM__element_at(x:any,y:literal(int))->(|x):"elem" + +proc elements(x)=_elements(x,1) +proc _elements(x,i:literal(int)) { + const e + if fix(i==num_elements(x)) { + e=_cons(PM__element_at(x,i),_list_end) + } else { + e=_cons(PM__element_at(x,i),_elements(x,i+1)) + } + return e +} + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnt(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=PM__cast(x,typeof(t)) +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic<> error_type()->(?0) : "call" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump(x)<>:_dump("Value:",x) +proc PM__dump(y,x)<>:if y:_dump("Value:",x) +proc PM__dump%(x)<>{ + print("$"++here) + _dump(string(here),x) +} +proc PM__dump%(y:bool,x)<>{ + if y:_dump(string(here),x) +} +proc PM__dump%(y,x){ + test "Selection expression in ""$$dump"" not ""bool""" => fix(false) + $$infer_type(y) +} +PM__intrinsic<> old_dump(any): "dump" +proc old_dumpit(a) { + old_dump(a) + return a +} + +PM__intrinsic<> old_dump_id(any): "dump_id" + +proc PM__filesys()=1 diff --git a/pm/lib/sys/pm_b4.pmm b/pm/lib/sys/pm_b4.pmm new file mode 100644 index 0000000..447efa4 --- /dev/null +++ b/pm/lib/sys/pm_b4.pmm @@ -0,0 +1,5268 @@ +/* + PM (Parallel Models) Programming Language + + Released under the MIT License (MIT) + Copyright (c) Tim Bellerby, 2024 + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + + +/* +type int_literal is ^^^int +type real_literal is ^^^real +type bool_literal is ^^^bool +type string_literal is ^^^string +*/ + +type literal is ^^^any + +PM__intrinsic num_elements(any)->(int_literal) : "num_elems_fold" + +PM__intrinsic mod(int_literal,int_literal)->(int_literal) : "mod_fold" +PM__intrinsic ==(int_literal,int_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(int_literal,int_literal)->(bool_literal) : "ne_fold" +PM__intrinsic >=(int_literal,int_literal)->(bool_literal) : "ge_fold" +PM__intrinsic >(int_literal,int_literal)->(bool_literal) : "gt_fold" +PM__intrinsic +(int_literal,int_literal)->(int_literal) : "add_fold" +PM__intrinsic -(int_literal,int_literal)->(int_literal) : "sub_fold" +PM__intrinsic *(int_literal,int_literal)->(int_literal) : "mult_fold" +PM__intrinsic /(int_literal,int_literal)->(int_literal) : "divide_fold" +PM__intrinsic **(int_literal,int_literal)->(int_literal) : "pow_fold" +PM__intrinsic max(int_literal,int_literal)->(int_literal) : "max_fold" +PM__intrinsic min(int_literal,int_literal)->(int_literal) : "min_fold" +PM__intrinsic -(int_literal)->(int_literal) : "uminus_fold" +PM__intrinsic string(int_literal)->(string_literal) : "string_fold" +PM__intrinsic abs(int_literal)->(int_literal) : "abs_fold" +PM__intrinsic ~(int_literal)->(int_literal) : "bnot_fold" +PM__intrinsic &(int_literal,int_literal)->(int_literal) : "band_fold" +PM__intrinsic |(int_literal,int_literal)->(int_literal) : "bor_fold" +PM__intrinsic xor(int_literal,int_literal)->(int_literal) : "bxor_fold" +PM__intrinsic shift(int_literal,int_literal)->(int_literal) : "bshift_fold" +PM__intrinsic pdiff(int_literal,int_literal)->(int_literal) : "pdiff_fold" +PM__intrinsic sign(int_literal,int_literal)->(int_literal) : "sign_fold" +PM__intrinsic rem(int_literal,int_literal)->(int_literal) : "modulo_fold" +PM__intrinsic and(bool_literal,bool_literal)->(bool_literal) : "and_fold" +PM__intrinsic or(bool_literal,bool_literal)->(bool_literal) : "or_fold" +PM__intrinsic except(bool_literal,bool_literal)->(bool_literal) : "except_fold" +PM__intrinsic ==(bool_literal,bool_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(bool_literal,bool_literal)->(bool_literal) : "ne_fold" +PM__intrinsic ==(string_literal,string_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(string_literal,string_literal)->(bool_literal) : "ne_fold" +PM__intrinsic ==(real_literal,real_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(real_literal,real_literal)->(bool_literal) : "ne_fold" +PM__intrinsic ++(string_literal,string_literal)->(string_literal) : "concat_fold" +PM__intrinsic mod(fix int,fix int)->(fix int) : "mod_fold" +PM__intrinsic ==(fix int,fix int)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix int,fix int)->(fix bool) : "ne_fold" +PM__intrinsic >=(fix int,fix int)->(fix bool) : "ge_fold" +PM__intrinsic >(fix int,fix int)->(fix bool) : "gt_fold" +PM__intrinsic +(fix int,fix int)->(fix int) : "add_fold" +PM__intrinsic -(fix int,fix int)->(fix int) : "sub_fold" +PM__intrinsic *(fix int,fix int)->(fix int) : "mult_fold" +PM__intrinsic /(fix int,fix int)->(fix int) : "divide_fold" +PM__intrinsic **(fix int,fix int)->(fix int) : "pow_fold" +PM__intrinsic max(fix int,fix int)->(fix int) : "max_fold" +PM__intrinsic min(fix int,fix int)->(fix int) : "min_fold" +PM__intrinsic -(fix int)->(fix int) : "uminus_fold" +PM__intrinsic string(fix int)->(fix string) : "string_fold" +PM__intrinsic abs(fix int)->(fix int) : "abs_fold" +PM__intrinsic ~(fix int)->(fix int) : "bnot_fold" +PM__intrinsic &(fix int,fix int)->(fix int) : "band_fold" +PM__intrinsic |(fix int,fix int)->(fix int) : "bor_fold" +PM__intrinsic xor(fix int,fix int)->(fix int) : "bxor_fold" +PM__intrinsic shift(fix int,fix int)->(fix int) : "bshift_fold" +PM__intrinsic pdiff(fix int,fix int)->(fix int) : "pdiff_fold" +PM__intrinsic sign(fix int,fix int)->(fix int) : "sign_fold" +PM__intrinsic rem(fix int,fix int)->(fix int) : "modulo_fold" +PM__intrinsic and(fix bool,fix bool)->(fix bool) : "and_fold" +PM__intrinsic or(fix bool,fix bool)->(fix bool) : "or_fold" +PM__intrinsic except(fix bool,fix bool)->(fix bool) : "except_fold" +PM__intrinsic ==(fix bool,fix bool)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix bool,fix bool)->(fix bool) : "ne_fold" +PM__intrinsic ==(fix string,fix string)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix string,fix string)->(fix bool) : "ne_fold" +PM__intrinsic ==(fix real,fix real)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix real,fix real)->(fix bool) : "ne_fold" +PM__intrinsic ++(fix string,fix string)->(fix string) : "concat_fold" + +// ************************************** +// BASIC TYPES +// ************************************** + +// String type +PM__intrinsic<> print(string): "print" + +proc print(x) { + print(string(x)) +} + +PM__intrinsic<> print_all(string): "print"(1) + +proc print_all(x) { + print_all(string(x)) +} + +PM__intrinsic ++(string,string)->(string) : "concat" + +proc ++(x:string,y)=$++.(x,string(y)) +proc ++(x,y)=$++.(string(x),string(y)) +proc string(x:string)=x +proc string(x:null)="null" +proc fmt(x,y)=x:test """fmt"" operator not yet implmented"=>'false + +// sint type +PM__intrinsic PM__assign_var(&sint,sint): "assign_i" +PM__intrinsic mod(sint,sint)->(sint) : "mod_i" +PM__intrinsic ==(sint,sint)->(bool) : "eq_i" +PM__intrinsic /=(sint,sint)->(bool) : "ne_i" +PM__intrinsic >=(sint,sint)->(bool) : "ge_i" +PM__intrinsic >(sint,sint)->(bool) : "gt_i" +PM__intrinsic +(sint,sint)->(sint) : "add_i" +PM__intrinsic -(sint,sint)->(sint) : "sub_i" +PM__intrinsic *(sint,sint)->(sint) : "mult_i" +PM__intrinsic /(sint,sint)->(sint) : "divide_i" +PM__intrinsic **(sint,sint)->(sint) : "pow_i" +PM__intrinsic max(sint,sint)->(sint) : "max_i" +PM__intrinsic min(sint,sint)->(sint) : "min_i" +PM__intrinsic -(sint)->(sint) : "uminus_i" +PM__intrinsic string(sint)->(string) : "string_i" +PM__intrinsic int(sint)->(int) : "long_i" +PM__intrinsic sreal(sint)->(sreal) : "real_i" +PM__intrinsic real(sint)->(real) : "double_i" +proc sint(x:sint)=x +PM__intrinsic abs(sint)->(sint) : "abs_i" +PM__intrinsic bit_not(sint)->(sint) : "bnot_i" +PM__intrinsic &(sint,sint)->(sint) : "band_i" +PM__intrinsic |(sint,sint)->(sint) : "bor_i" +PM__intrinsic xor(sint,sint)->(sint) : "bxor_i" +PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" +PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" +PM__intrinsic sign(sint,sint)->(sint) : "sign_i" +PM__intrinsic rem(sint,sint)->(sint) : "modulo_i" +PM__intrinsic int8(sint)->(int8) : "i8_i" +PM__intrinsic int16(sint)->(int16) : "i16_i" +PM__intrinsic int32(sint)->(int32) : "i32_i" +PM__intrinsic int64(sint)->(int64) : "i64_i" +PM__intrinsic lint(sint)->(lint) : "offset_i" + +// int type +PM__intrinsic PM__assign_var(&int,int): "assign_ln" +PM__intrinsic mod(int,int)->(int) : "mod_ln" +PM__intrinsic ==(int,int)->(bool) : "eq_ln" +PM__intrinsic /=(int,int)->(bool) : "ne_ln" +PM__intrinsic >=(int,int)->(bool) : "ge_ln" +PM__intrinsic >(int,int)->(bool) : "gt_ln" +PM__intrinsic +(int,int)->(int) : "add_ln" +PM__intrinsic -(int,int)->(int) : "sub_ln" +PM__intrinsic *(int,int)->(int) : "mult_ln" +proc *(x:int,y:'1)=x +PM__intrinsic /(int,int)->(int) : "divide_ln" +proc /(x:int,y:'1)=x +PM__intrinsic **(int,int)->(int) : "pow_ln" +PM__intrinsic max(int,int)->(int) : "max_ln" +PM__intrinsic min(int,int)->(int) : "min_ln" +PM__intrinsic -(int)->(int) : "uminus_ln" +PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic sint(int)->(sint) : "int_ln" +PM__intrinsic sreal(int)->(sreal) : "real_ln" +PM__intrinsic real(int)->(real) : "double_ln" +proc int(x:int)=x +PM__intrinsic abs(int)->(int) : "abs_ln" +PM__intrinsic ~(int)->(int) : "bnot_ln" +PM__intrinsic &(int,int)->(int) : "band_ln" +PM__intrinsic |(int,int)->(int) : "bor_ln" +PM__intrinsic xor(int,int)->(int) : "bxor_ln" +PM__intrinsic shift(int,int)->(int) : "bshift_ln" +PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" +PM__intrinsic sign(int,int)->(int) : "sign_ln" +PM__intrinsic rem(int,int)->(int) : "modulo_ln" +PM__intrinsic int8(int)->(int8) : "i8_ln" +PM__intrinsic int16(int)->(int16) : "i16_ln" +PM__intrinsic int32(int)->(int32) : "i32_ln" +PM__intrinsic int64(int)->(int64) : "i64_ln" +PM__intrinsic lint(int)->(lint) : "offset_ln" + +// lint type +PM__intrinsic PM__assign_var(&lint,lint): "assign_offset" +PM__intrinsic mod(lint,lint)->(lint) : "mod_offset" +PM__intrinsic ==(lint,lint)->(bool) : "eq_offset" +PM__intrinsic /=(lint,lint)->(bool) : "ne_offset" +PM__intrinsic >=(lint,lint)->(bool) : "ge_offset" +PM__intrinsic >(lint,lint)->(bool) : "gt_offset" +PM__intrinsic +(lint,lint)->(lint) : "add_offset" +proc +(x:lint,y:'0)=x +proc +(x:'0,y:lint)=y +PM__intrinsic -(lint,lint)->(lint) : "sub_offset" +proc -(x:lint,y:'0)=x +PM__intrinsic *(lint,lint)->(lint) : "mult_offset" +proc *(x:lint,y:'1)=x +proc *(x:'1,y:lint)=y +PM__intrinsic /(lint,lint)->(lint) : "divide_offset" +proc /(x:lint,y:'1)=x +PM__intrinsic **(lint,lint)->(lint) : "pow_offset" +proc **(x:lint,y:'0)=1 +proc **(x:lint,y:'1)=x +proc **(x:lint,y:'2)=x*x +PM__intrinsic max(lint,lint)->(lint) : "max_offset" +PM__intrinsic min(lint,lint)->(lint) : "min_offset" +PM__intrinsic -(lint)->(lint) : "uminus_offset" +PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic sint(lint)->(sint) : "int_offset" +PM__intrinsic sreal(lint)->(sreal) : "real_offset" +PM__intrinsic real(lint)->(real) : "double_offset" +proc lint(x:lint)=x +PM__intrinsic abs(lint)->(lint) : "abs_offset" +PM__intrinsic ~(lint)->(lint) : "bnot_offset" +PM__intrinsic &(lint,lint)->(lint) : "band_offset" +PM__intrinsic |(lint,lint)->(lint) : "bor_offset" +PM__intrinsic xor(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" +PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" +PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" +PM__intrinsic rem(lint,lint)->(lint) : "modulo_offset" +PM__intrinsic int8(lint)->(int8) : "i8_offset" +PM__intrinsic int16(lint)->(int16) : "i16_offset" +PM__intrinsic int32(lint)->(int32) : "i32_offset" +PM__intrinsic int64(lint)->(int64) : "i64_offset" +PM__intrinsic int(lint)->(int) : "long_offset" + +// int8 type +PM__intrinsic PM__assign_var(&int8,int8): "assign_i8" +PM__intrinsic mod(int8,int8)->(int8) : "mod_i8" +PM__intrinsic ==(int8,int8)->(bool) : "eq_i8" +PM__intrinsic /=(int8,int8)->(bool) : "ne_i8" +PM__intrinsic >=(int8,int8)->(bool) : "ge_i8" +PM__intrinsic >(int8,int8)->(bool) : "gt_i8" +PM__intrinsic +(int8,int8)->(int8) : "add_i8" +proc +(x:int8,y:'0)=x +proc +(x:'0,y:int8)=y +PM__intrinsic -(int8,int8)->(int8) : "sub_i8" +proc -(x:int8,y:'0)=x +PM__intrinsic *(int8,int8)->(int8) : "mult_i8" +proc *(x:int8,y:'1)=x +proc *(x:'1,y:int8)=y +PM__intrinsic /(int8,int8)->(int8) : "divide_i8" +proc /(x:int8,y:'1)=x +PM__intrinsic **(int8,int8)->(int8) : "pow_i8" +proc **(x:int8,y:'0)=1 +proc **(x:int8,y:'1)=x +proc **(x:int8,y:'2)=x*x +PM__intrinsic max(int8,int8)->(int8) : "max_i8" +PM__intrinsic min(int8,int8)->(int8) : "min_i8" +PM__intrinsic -(int8)->(int8) : "uminus_i8" +PM__intrinsic sint(int8)->(sint) : "int_i8" +PM__intrinsic sreal(int8)->(sreal) : "real_i8" +PM__intrinsic real(int8)->(real) : "double_i8" +proc int8(x:int8)=x +PM__intrinsic abs(int8)->(int8) : "abs_i8" +PM__intrinsic ~(int8)->(int8) : "bnot_i8" +PM__intrinsic &(int8,int8)->(int8) : "band_i8" +PM__intrinsic |(int8,int8)->(int8) : "bor_i8" +PM__intrinsic xor(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" +PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" +PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" +PM__intrinsic rem(int8,int8)->(int8) : "modulo_i8" +PM__intrinsic int16(int8)->(int16) : "i16_i8" +PM__intrinsic int32(int8)->(int32) : "i32_i8" +PM__intrinsic int64(int8)->(int64) : "i64_i8" +PM__intrinsic int(int8)->(int) : "long_i8" +PM__intrinsic lint(int8)->(lint) : "offset_i8" + +// int16 type +PM__intrinsic PM__assign_var(&int16,int16): "assign_i16" +PM__intrinsic mod(int16,int16)->(int16) : "mod_i16" +PM__intrinsic ==(int16,int16)->(bool) : "eq_i16" +PM__intrinsic /=(int16,int16)->(bool) : "ne_i16" +PM__intrinsic >=(int16,int16)->(bool) : "ge_i16" +PM__intrinsic >(int16,int16)->(bool) : "gt_i16" +PM__intrinsic +(int16,int16)->(int16) : "add_i16" +proc +(x:int16,y:'0)=x +proc +(x:'0,y:int16)=y +PM__intrinsic -(int16,int16)->(int16) : "sub_i16" +proc -(x:int16,y:'0)=x +PM__intrinsic *(int16,int16)->(int16) : "mult_i16" +proc *(x:int16,y:'1)=x +proc *(x:'1,y:int16)=y +PM__intrinsic /(int16,int16)->(int16) : "divide_i16" +proc /(x:int16,y:'1)=x +PM__intrinsic **(int16,int16)->(int16) : "pow_i16" +proc **(x:int16,y:'0)=1 +proc **(x:int16,y:'1)=x +proc **(x:int16,y:'2)=x*x +PM__intrinsic max(int16,int16)->(int16) : "max_i16" +PM__intrinsic min(int16,int16)->(int16) : "min_i16" +PM__intrinsic -(int16)->(int16) : "uminus_i16" +PM__intrinsic sint(int16)->(sint) : "int_i16" +PM__intrinsic sreal(int16)->(sreal) : "real_i16" +PM__intrinsic real(int16)->(real) : "double_i16" +proc int16(x:int16)=x +PM__intrinsic abs(int16)->(int16) : "abs_i16" +PM__intrinsic ~(int16)->(int16) : "bnot_i16" +PM__intrinsic &(int16,int16)->(int16) : "band_i16" +PM__intrinsic |(int16,int16)->(int16) : "bor_i16" +PM__intrinsic xor(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" +PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" +PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" +PM__intrinsic rem(int16,int16)->(int16) : "modulo_i16" +PM__intrinsic int8(int16)->(int16) : "i8_i16" +PM__intrinsic int32(int16)->(int32) : "i32_i16" +PM__intrinsic int64(int16)->(int64) : "i64_i16" +PM__intrinsic int(int16)->(int) : "long_i16" +PM__intrinsic lint(int16)->(lint) : "offset_i16" + +// int32 type +PM__intrinsic PM__assign_var(&int32,int32): "assign_i32" +PM__intrinsic mod(int32,int32)->(int32) : "mod_i32" +PM__intrinsic ==(int32,int32)->(bool) : "eq_i32" +PM__intrinsic /=(int32,int32)->(bool) : "ne_i32" +PM__intrinsic >=(int32,int32)->(bool) : "ge_i32" +PM__intrinsic >(int32,int32)->(bool) : "gt_i32" +PM__intrinsic +(int32,int32)->(int32) : "add_i32" +proc +(x:int32,y:'0)=x +proc +(x:'0,y:int32)=y +PM__intrinsic -(int32,int32)->(int32) : "sub_i32" +proc -(x:int32,y:'0)=x +PM__intrinsic *(int32,int32)->(int32) : "mult_i32" +proc *(x:int32,y:'1)=x +proc *(x:'1,y:int32)=y +PM__intrinsic /(int32,int32)->(int32) : "divide_i32" +proc /(x:int32,y:'1)=x +PM__intrinsic **(int32,int32)->(int32) : "pow_i32" +proc **(x:int32,y:'0)=1 +proc **(x:int32,y:'1)=x +proc **(x:int32,y:'2)=x*x +PM__intrinsic max(int32,int32)->(int32) : "max_i32" +PM__intrinsic min(int32,int32)->(int32) : "min_i32" +PM__intrinsic -(int32)->(int32) : "uminus_i32" +PM__intrinsic sint(int32)->(sint) : "int_i32" +PM__intrinsic sreal(int32)->(sreal) : "real_i32" +PM__intrinsic real(int32)->(real) : "double_i32" +proc int32(x:int32)=x +PM__intrinsic abs(int32)->(int32) : "abs_i32" +PM__intrinsic ~(int32)->(int32) : "bnot_i32" +PM__intrinsic &(int32,int32)->(int32) : "band_i32" +PM__intrinsic |(int32,int32)->(int32) : "bor_i32" +PM__intrinsic xor(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" +PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" +PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" +PM__intrinsic rem(int32,int32)->(int32) : "modulo_i32" +PM__intrinsic int8(int32)->(int32) : "i8_i32" +PM__intrinsic int16(int32)->(int32) : "i16_i32" +PM__intrinsic int64(int32)->(int64) : "i64_i32" +PM__intrinsic int(int32)->(int) : "long_i32" +PM__intrinsic lint(int32)->(lint) : "offset_i32" + +// int64 type +PM__intrinsic PM__assign_var(&int64,int64): "assign_i64" +PM__intrinsic mod(int64,int64)->(int64) : "mod_i64" +PM__intrinsic ==(int64,int64)->(bool) : "eq_i64" +PM__intrinsic /=(int64,int64)->(bool) : "ne_i64" +PM__intrinsic >=(int64,int64)->(bool) : "ge_i64" +PM__intrinsic >(int64,int64)->(bool) : "gt_i64" +PM__intrinsic +(int64,int64)->(int64) : "add_i64" +proc +(x:int64,y:'0)=x +proc +(x:'0,y:int64)=y +PM__intrinsic -(int64,int64)->(int64) : "sub_i64" +proc -(x:int64,y:'0)=x +PM__intrinsic *(int64,int64)->(int64) : "mult_i64" +proc *(x:int64,y:'1)=x +proc *(x:'1,y:int64)=y +PM__intrinsic /(int64,int64)->(int64) : "divide_i64" +proc /(x:int64,y:'1)=x +PM__intrinsic **(int64,int64)->(int64) : "pow_i64" +proc **(x:int64,y:'0)=1 +proc **(x:int64,y:'1)=x +proc **(x:int64,y:'2)=x*x +PM__intrinsic max(int64,int64)->(int64) : "max_i64" +PM__intrinsic min(int64,int64)->(int64) : "min_i64" +PM__intrinsic -(int64)->(int64) : "uminus_i64" +PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic sint(int64)->(sint) : "int_i64" +PM__intrinsic sreal(int64)->(sreal) : "real_i64" +PM__intrinsic real(int64)->(real) : "double_i64" +proc int64(x:int64)=x +PM__intrinsic abs(int64)->(int64) : "abs_i64" +PM__intrinsic ~(int64)->(int64) : "bnot_i64" +PM__intrinsic &(int64,int64)->(int64) : "band_i64" +PM__intrinsic |(int64,int64)->(int64) : "bor_i64" +PM__intrinsic xor(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" +PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" +PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" +PM__intrinsic rem(int64,int64)->(int64) : "modulo_i64" +PM__intrinsic int8(int64)->(int64) : "i8_i64" +PM__intrinsic int16(int64)->(int64) : "i16_i64" +PM__intrinsic int32(int64)->(int64) : "i32_i64" +PM__intrinsic int(int64)->(int) : "long_i64" +PM__intrinsic lint(int64)->(lint) : "offset_i64" + +// sreal type +PM__intrinsic PM__assign_var(&sreal,sreal): "assign_r" +PM__intrinsic mod(sreal,sreal)->(sreal) : "mod_r" +PM__intrinsic ==(sreal,sreal)->(bool) : "eq_r" +PM__intrinsic /=(sreal,sreal)->(bool) : "ne_r" +PM__intrinsic >=(sreal,sreal)->(bool) : "ge_r" +PM__intrinsic >(sreal,sreal)->(bool) : "gt_r" +PM__intrinsic +(sreal,sreal)->(sreal) : "add_r" +PM__intrinsic -(sreal,sreal)->(sreal) : "sub_r" +PM__intrinsic *(sreal,sreal)->(sreal) : "mult_r" +PM__intrinsic /(sreal,sreal)->(sreal) : "divide_r" +PM__intrinsic **(sreal,sreal)->(sreal) : "pow_r" +PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" +PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" +PM__intrinsic -(sreal)->(sreal) : "uminus_r" +PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic strunc(sreal)->(sint) : "int_r" +PM__intrinsic trunc(sreal)->(int) : "long_r" +PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" +PM__intrinsic real(sreal)->(real) : "double_r" +proc sreal(x:sreal)=x +PM__intrinsic abs(sreal)->(sreal) : "abs_r" +PM__intrinsic acos(sreal)->(sreal) : "acos_r" +PM__intrinsic asin(sreal)->(sreal) : "asin_r" +PM__intrinsic atan(sreal)->(sreal) : "atan_r" +PM__intrinsic atan2(sreal,sreal)->(sreal) : "atan2_r" +PM__intrinsic cos(sreal)->(sreal) : "cos_r" +PM__intrinsic cosh(sreal)->(sreal) : "cosh_r" +PM__intrinsic exp(sreal)->(sreal) : "exp_r" +PM__intrinsic log(sreal)->(sreal) : "log_r" +PM__intrinsic log10(sreal)->(sreal) : "log10_r" +PM__intrinsic sin(sreal)->(sreal) : "sin_r" +PM__intrinsic sinh(sreal)->(sreal) : "sinh_r" +PM__intrinsic sqrt(sreal)->(sreal) : "sqrt_r" +PM__intrinsic tan(sreal)->(sreal) : "tan_r" +PM__intrinsic tanh(sreal)->(sreal) : "tanh_r" +PM__intrinsic floor(sreal)->(sreal) : "floor_r" +PM__intrinsic ceil(sreal)->(sreal) : "ceil_r" +PM__intrinsic rem(sreal,sreal)->(sreal) : "modulo_r" +PM__intrinsic sign(sreal,sreal)->(sreal) : "sign_r" +PM__intrinsic pdiff(sreal,sreal)->(sreal) : "pdiff_r" +PM__intrinsic lint(sreal)->(lint) : "offset_r" +PM__intrinsic scpx(sreal)->(scpx) : "complex_r" +PM__intrinsic _scpx2(sreal,sreal)->(scpx) : "complex2_r" +proc scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y)) + +// real type +PM__intrinsic PM__assign_var(&real,real): "assign_d" +PM__intrinsic mod(real,real)->(real) : "mod_d" +PM__intrinsic ==(real,real)->(bool) : "eq_d" +PM__intrinsic /=(real,real)->(bool) : "ne_d" +PM__intrinsic >=(real,real)->(bool) : "ge_d" +PM__intrinsic >(real,real)->(bool) : "gt_d" +PM__intrinsic +(real,real)->(real) : "add_d" +PM__intrinsic -(real,real)->(real) : "sub_d" +PM__intrinsic *(real,real)->(real) : "mult_d" +PM__intrinsic /(real,real)->(real) : "divide_d" +PM__intrinsic **(real,real)->(real) : "pow_d" +PM__intrinsic max(real,real)->(real) : "max_d" +PM__intrinsic min(real,real)->(real) : "min_d" +PM__intrinsic -(real)->(real) : "uminus_d" +PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic strunc(real)->(sint) : "int_d" +PM__intrinsic trunc(real)->(int) : "long_d" +PM__intrinsic ltrunc(real)->(lint) : "offset_d" +PM__intrinsic sreal(real)->(sreal) : "real_d" +proc real(x:real)=x +PM__intrinsic abs(real)->(real) : "abs_d" +PM__intrinsic acos(real)->(real) : "acos_d" +PM__intrinsic asin(real)->(real) : "asin_d" +PM__intrinsic atan(real)->(real) : "atan_d" +PM__intrinsic atan2(real,real)->(real) : "atan2_d" +PM__intrinsic cos(real)->(real) : "cos_d" +PM__intrinsic cosh(real)->(real) : "cosh_d" +PM__intrinsic exp(real)->(real) : "exp_d" +PM__intrinsic log(real)->(real) : "log_d" +PM__intrinsic log10(real)->(real) : "log10_d" +PM__intrinsic sin(real)->(real) : "sin_d" +PM__intrinsic sinh(real)->(real) : "sinh_d" +PM__intrinsic sqrt(real)->(real) : "sqrt_d" +PM__intrinsic tan(real)->(real) : "tan_d" +PM__intrinsic tanh(real)->(real) : "tanh_d" +PM__intrinsic floor(real)->(real) : "floor_d" +PM__intrinsic ceil(real)->(real) : "ceil_d" +PM__intrinsic rem(real,real)->(real) : "modulo_d" +PM__intrinsic sign(real,real)->(real) : "sign_d" +PM__intrinsic pdiff(real,real)->(real) : "pdiff_d" +PM__intrinsic lint(real)->(lint) : "offset_d" +PM__intrinsic cpx(real)->(cpx) : "complex_d" +PM__intrinsic _cpx2(real,real)->(cpx) : "complex2_d" +proc cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y)) + +// scpx type +PM__intrinsic PM__assign_var(&scpx,scpx): "assign_c" +PM__intrinsic +(scpx,scpx)->(scpx) : "add_c" +PM__intrinsic -(scpx,scpx)->(scpx) : "sub_c" +PM__intrinsic *(scpx,scpx)->(scpx) : "mult_c" +PM__intrinsic /(scpx,scpx)->(scpx) : "divide_c" +PM__intrinsic **(scpx,sreal)->(scpx) : "rpow_c" +PM__intrinsic **(scpx,scpx)->(scpx) : "pow_c" +PM__intrinsic -(scpx)->(scpx) : "uminus_c" +PM__intrinsic ==(scpx,scpx)->(bool) : "eq_c" +PM__intrinsic /=(scpx,scpx)->(bool) : "ne_c" +PM__intrinsic re(scpx)->(sreal) : "real_c" +PM__intrinsic abs(scpx)->(scpx) : "abs_c" +PM__intrinsic acos(scpx)->(scpx) : "acos_c" +PM__intrinsic asin(scpx)->(scpx) : "asin_c" +PM__intrinsic atan(scpx)->(scpx) : "atan_c" +PM__intrinsic atan2(scpx,scpx)->(scpx) : "atan2_c" +PM__intrinsic cos(scpx)->(scpx) : "cos_c" +PM__intrinsic cosh(scpx)->(scpx) : "cosh_c" +PM__intrinsic exp(scpx)->(scpx) : "exp_c" +PM__intrinsic log(scpx)->(scpx) : "log_c" +PM__intrinsic sin(scpx)->(scpx) : "sin_c" +PM__intrinsic sinh(scpx)->(scpx) : "sinh_c" +PM__intrinsic sqrt(scpx)->(scpx) : "sqrt_c" +PM__intrinsic tan(scpx)->(scpx) : "tan_c" +PM__intrinsic tanh(scpx)->(scpx) : "tanh_c" +PM__intrinsic im(scpx)->(sreal) : "imag_c" +PM__intrinsic conj(scpx)->(scpx) : "conj_c" + +// cpx type +PM__intrinsic PM__assign_var(&cpx,cpx): "assign_dc" +PM__intrinsic +(cpx,cpx)->(cpx) : "add_dc" +PM__intrinsic -(cpx,cpx)->(cpx) : "sub_dc" +PM__intrinsic *(cpx,cpx)->(cpx) : "mult_dc" +PM__intrinsic /(cpx,cpx)->(cpx) : "divide_dc" +PM__intrinsic **(cpx,real)->(cpx) : "dpow_dc" +proc **(x:cpx,y:sreal)=x**real(y) +PM__intrinsic **(cpx,cpx)->(cpx) : "pow_dc" +PM__intrinsic -(cpx)->(cpx) : "uminus_dc" +PM__intrinsic ==(cpx,cpx)->(bool) : "eq_dc" +PM__intrinsic /=(cpx,cpx)->(bool) : "ne_dc" +PM__intrinsic re(cpx)->(real) : "real_dc" +PM__intrinsic abs(cpx)->(cpx) : "abs_dc" +PM__intrinsic acos(cpx)->(cpx) : "acos_dc" +PM__intrinsic asin(cpx)->(cpx) : "asin_dc" +PM__intrinsic atan(cpx)->(cpx) : "atan_dc" +PM__intrinsic atan2(cpx,cpx)->(cpx) : "atan2_dc" +PM__intrinsic cos(cpx)->(cpx) : "cos_dc" +PM__intrinsic cosh(cpx)->(cpx) : "cosh_dc" +PM__intrinsic exp(cpx)->(cpx) : "exp_dc" +PM__intrinsic log(cpx)->(cpx) : "log_dc" +PM__intrinsic sin(cpx)->(cpx) : "sin_dc" +PM__intrinsic sinh(cpx)->(cpx) : "sinh_dc" +PM__intrinsic sqrt(cpx)->(cpx) : "sqrt_dc" +PM__intrinsic tan(cpx)->(cpx) : "tan_dc" +PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" +PM__intrinsic im(cpx)->(real) : "imag_dc" +PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + +/* + +// Cannot convert real to int (must use nint or trunc) +proc sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => 'false +proc int(x:any_real)=0 :test "Cannot convert real to integer" => 'false +proc lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => 'false + +// Some numeric conversions not hard-coded +proc cpx(x:real_num)=cpx(real(x)) +proc scpx(x:real_num)=cpx(sreal(x)) +proc string(x:any_int)=string(int64(x)) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc int(x:fix int)=x + +// Abstract numeric types +type any_int is sint,int,lint,int8,int16,int32,int64 +type any_real is sreal,real +type any_cpx is scpx,cpx +type int_num is any_int +type real_num is int_num, any_real +type cpx_num is real_num,any_cpx +type num is cpx_num + +// Numeric type conversion +proc convert(x,y)=x +proc convert(x:int_num,y:sint)=sint(x) +proc convert(x:int_num,y:int)=int(x) +proc convert(x:int_num,y:lint)=lint(x) +proc convert(x:int_num,y:int8)=int8(x) +proc convert(x:int_num,y:int16)=int16(x) +proc convert(x:int_num,y:int32)=int32(x) +proc convert(x:int_num,y:int64)=int64(x) +proc convert(x:int_num,y:sreal)=sreal(x) +proc convert(x:int_num,y:real)=real(x) +proc convert(x:real_num,y:cpx)=cpx(x) +proc convert(x:real_num,y:scpx)=scpx(x) +proc as(x:int_num,y:)=sint(x) +proc as(x:int_num,y:)=int(x) +proc as(x:int_num,y:)=lint(x) +proc as(x:int_num,y:)=int8(x) +proc as(x:int_num,y:)=int16(x) +proc as(x:int_num,y:)=int32(x) +proc as(x:int_num,y:)=int64(x) +proc as(x:real_num,y:)=sreal(x) +proc as(x:real_num,y:)=real(x) +proc as(x:real_num,y:)=scpx(x) +proc as(x:real_num,y:)=cpx(x) + +// Auto-conversion on assignment +proc PM__assign(&x:num,y:num) { + _assign_element(&x,convert(y,x)) +} +proc PM__assign_var(&x:num,y:num) { + PM__assign(&x,convert(y,x)) +} + +// Mixed arithmatic +type _to_sint is int +type _to_lint is sint,int +type _to_int8 is sint,int,lint +type _to_int16 is sint,int,lint,int8 +type _to_int32 is sint,int,lint,int8,int16 +type _to_int64 is sint,int,lint,int8,int16,int32 +type _to_real is any_int +type _to_sreal is any_int,real +type _to_cpx is real_num +type _to_scpx is real_num,cpx +proc balance(x:sint,y:sint)=x,y +proc balance(x:int,y:int)=x,y +proc balance(x:lint,y:lint)=x,y +proc balance(x:int8,y:int8)=x,y +proc balance(x:int16,y:int16)=x,y +proc balance(x:int32,y:int32)=x,y +proc balance(x:int64,y:int64)=x,y +proc balance(x:sreal,y:sreal)=x,y +proc balance(x:real,y:real)=x,y +proc balance(x:scpx,y:scpx)=x,y +proc balance(x:cpx,y:cpx)=x,y +proc balance(x:sint,y:_to_sint)=x,sint(y) +proc balance(x:lint,y:_to_lint)=x,lint(y) +proc balance(x:int8,y:_to_int8)=x,int8(y) +proc balance(x:int16,y:_to_int16)=x,int16(y) +proc balance(x:int32,y:_to_int32)=x,int32(y) +proc balance(x:int64,y:_to_int64)=x,int64(y) +proc balance(x:sreal,y:_to_sreal)=x,sreal(y) +proc balance(x:real,y:_to_real)=x,real(y) +proc balance(x:scpx,y:_to_scpx)=x,scpx(y) +proc balance(x:cpx,y:_to_cpx)=x,cpx(y) +proc balance(x:_to_sint,y:sint)=sint(x),y +proc balance(x:_to_lint,y:lint)=lint(x),y +proc balance(x:_to_int8,y:int8)=int8(x),y +proc balance(x:_to_int16,y:int16)=int16(x),y +proc balance(x:_to_int32,y:int32)=int32(x),y +proc balance(x:_to_int64,y:int64)=int64(x),y +proc balance(x:_to_sreal,y:sreal)=sreal(x),y +proc balance(x:_to_real,y:real)=real(x),y +proc balance(x:_to_scpx,y:scpx)=scpx(x),y +proc balance(x:_to_cpx,y:cpx)=cpx(x),y +proc div(x:any_int,y:any_int)=if(sz=>r,-1-r)where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))where sz=sign(x,y)==x +proc _divz(x:any_int,y:any_int)=z { + var z,_=balance(x,y) + if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y) +} +proc mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y) +proc ==(x:num,y:num)=xx==yy where xx,yy=balance(x,y) +proc /=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y) +proc >=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y) +proc >(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y) +proc +(x:num,y:num)=xx+yy where xx,yy=balance(x,y) +proc -(x:num,y:num)=xx-yy where xx,yy=balance(x,y) +proc *(x:num,y:num)=xx*yy where xx,yy=balance(x,y) +proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) +proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) +proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) +proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) +proc xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y) +proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) +proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) +proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) +// bool type +PM__intrinsic PM__assign_var(&bool,bool): "assign_l" +PM__intrinsic string(bool)->(string) : "string_l" +PM__intrinsic and(bool,bool)->(bool) : "and" +PM__intrinsic or(bool,bool)->(bool) : "or" +PM__intrinsic not(bool)->(bool) : "not" +PM__intrinsic ==(bool,bool)->(bool) : "eq_l" +PM__intrinsic /=(bool,bool)->(bool) : "ne_l" + +// Masked types +type masked(x) is rec {_val:x,_there:bool} +proc |(x:masked,y)=if(x._there=>x._val,y) + check "Right operand of ""|"" does not match masked type on the left"=>same_type(x._val,y) + +proc masked(val,there:bool)=new masked { + _val=val,_there=there +} + +proc defined(x:masked)=x._there +proc val(x:masked)=x._val check "masked value is undefined"=>x._there + +proc get(&x,y:masked) { + if y._there{ + x=y._val + } +} + +proc get(&x,y:masked(x)) { + if y._there{ + x=y._val + } + return y._there +} + +// Polymorphic types +PM__intrinsic get(x:*any,y:any)->(=y) : "as" +PM__intrinsic<> get(&x:any,y:*any): "get_poly" +PM__intrinsic<> get(&x:any,y:*any)->(bool) : "get_poly2" +PM__intrinsic<> |(x:*any,y:any)->(=y) : "get_poly_or" + +// val function having null effect +proc val(x)=x + +// ******************************************** +// TUPLES +// ******************************************** + +// Tuple types +type tuple1d(t1) is rec {PM__d1:t1} +type tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2} +type tuple3d(t1,t2,t3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3} +type tuple4d(t1,t2,t3,t4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4} +type tuple5d(t1,t2,t3,t4,t5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5} +type tuple6d(t1,t2,t3,t4,t5,t6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6} +type tuple7d(t1,t2,t3,t4,t5,t6,t7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7} +type tuple1d_of(t) is tuple1d(t) +type tuple2d_of(t) is tuple2d(t,t) +type tuple3d_of(t) is tuple3d(t,t,t) +type tuple4d_of(t) is tuple4d(t,t,t,t) +type tuple5d_of(t) is tuple5d(t,t,t,t,t) +type tuple6d_of(t) is tuple6d(t,t,t,t,t,t) +type tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t) +type tuple(t) is tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),tuple5d(t,t,t,t,t), + tuple6d(t,t,t,t,t,t),tuple7d(t,t,t,t,t,t,t) + +proc tuple(x)=new tuple1d { + PM__d1=x +} +proc tuple(x,y)=new tuple2d { + PM__d1=x,PM__d2=y +} +proc tuple(x,y,z)=new tuple3d { + PM__d1=x,PM__d2=y,PM__d3=z +} +proc tuple(x,y,z,t)=new tuple4d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t +} +proc tuple(x,y,z,t,u)=new tuple5d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u +} +proc tuple(x,y,z,t,u,v)=new tuple6d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v +} +proc tuple(x,y,z,t,u,v,w)=new tuple7d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w +} + +proc get_dim(t:tuple1d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple2d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple3d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple4d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple5d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple6d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple7d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple2d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple3d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple4d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple5d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple6d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple7d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple3d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple4d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple5d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple6d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple7d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple4d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple5d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple6d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple7d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple5d,n:'5 or ['5])=t.5 +proc get_dim(t:tuple6d,n:'5 or ['5])=t.5 +proc get_dim(t:tuple7d,n:'5 or ['5])=t.5 +proc get_dim(t:tuple6d,n:'6 or ['6])=t.6 +proc get_dim(t:tuple7d,n:'6 or ['6])=t.6 +proc get_dim(t:tuple7d,n:'7 or ['7])=t.7 + +proc indices(x:tuple1d)=['1] +proc indices(x:tuple2d)=['1,'2] +proc indices(x:tuple3d)=['1,'2,'3] +proc indices(x:tuple4d)=['1,'2,'3,'4] +proc indices(x:tuple5d)=['1,'2,'3,'4,'5] +proc indices(x:tuple6d)=['1,'2,'3,'4,'5,'6] +proc indices(x:tuple7d)=['1,'2,'3,'4,'5,'6,'7] + +proc full_rank(x:tuple1d)=1 +proc full_rank(x:tuple2d)=2 +proc full_rank(x:tuple3d)=3 +proc full_rank(x:tuple4d)=4 +proc full_rank(x:tuple5d)=5 +proc full_rank(x:tuple6d)=6 +proc full_rank(x:tuple7d)=7 +proc rank(x:tuple)=full_rank(x) + +proc reduce(p:proc,x:tuple1d)=x.1 +proc reduce(p:proc,x:tuple2d)=p.(x.2,x.1) +proc reduce(p:proc,x:tuple3d)=p.(p.(x.3,x.2),x.1) +proc reduce(p:proc,x:tuple4d)=p.(p.(p.(x.4,x.3),x.2),x.1) +proc reduce(p:proc,x:tuple5d)=p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple6d)=p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1) + +proc map(p:proc,x:tuple1d)=[p.(x.1)] +proc map(p:proc,x:tuple2d)=[p.(x.1),p.(x.2)] +proc map(p:proc,x:tuple3d)=[p.(x.1),p.(x.2),p.(x.3)] +proc map(p:proc,x:tuple4d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4)] +proc map(p:proc,x:tuple5d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)] +proc map(p:proc,x:tuple6d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)] +proc map(p:proc,x:tuple7d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)] +proc map(p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map(p:proc,x:tuple1d,y:tuple1d)=[p.(x.1,y.1)] +proc map(p:proc,x:tuple2d,y:tuple2d)=[p.(x.1,y.1),p.(x.2,y.2)] +proc map(p:proc,x:tuple3d,y:tuple3d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)] +proc map(p:proc,x:tuple4d,y:tuple4d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4)] +proc map(p:proc,x:tuple5d,y:tuple5d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5)] +proc map(p:proc,x:tuple6d,y:tuple6d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)] +proc map(p:proc,x:tuple7d,y:tuple7d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)] +proc map(p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(x.1,y.1,z.1)] +proc map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)] +proc map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)] +proc map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4)] +proc map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)] +proc map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)] +proc map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),p.(x.7,y.7,z.7)] + +proc map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(w.1,x.1,y.1,z.1)] +proc map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)] +proc map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)] +proc map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4)] +proc map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)] +proc map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)] +proc map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),p.(w.7,x.7,y.7,z.7)] + +proc map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]where u1,v1=p.(x.1,y.1) +proc map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2) +proc map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3) +proc map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4) +proc map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5) +proc map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6) +proc map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7) + +proc map_const(p:proc,x:tuple1d,y)=[p.(x.1,y)] +proc map_const(p:proc,x:tuple2d,y)=[p.(x.1,y),p.(x.2,y)] +proc map_const(p:proc,x:tuple3d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y)] +proc map_const(p:proc,x:tuple4d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y)] +proc map_const(p:proc,x:tuple5d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y)] +proc map_const(p:proc,x:tuple6d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y)] +proc map_const(p:proc,x:tuple7d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)] + +proc map_reduce(q:proc,p:proc,x:tuple1d)=q.(x.1) +proc map_reduce(q:proc,p:proc,x:tuple2d)=p.(q.(x.2),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d)=p.(p.(q.(x.3),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d)=p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d)=p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d)=p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)=q.(x.1,y.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.2,y.2),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(p.(q.(x.3,y.3),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=q.(x.1,y.1,z.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) + +proc apply(p:proc,x:tuple1d)=p.(x.1) +proc apply(p:proc,x:tuple2d)=p.(x.1,x.2) +proc apply(p:proc,x:tuple3d)=p.(x.1,x.2,x.3) +proc apply(p:proc,x:tuple4d)=p.(x.1,x.2,x.3,x.4) +proc apply(p:proc,x:tuple5d)=p.(x.1,x.2,x.3,x.4,x.5) +proc apply(p:proc,x:tuple6d)=p.(x.1,x.2,x.3,x.4,x.5,x.6) +proc apply(p:proc,x:tuple7d)=p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7) + +proc map_apply(q:proc,p:proc,x:tuple1d)=p.(q.(x.1)) +proc map_apply(q:proc,p:proc,x:tuple2d)=p.(q.(x.1),q.(x.2)) +proc map_apply(q:proc,p:proc,x:tuple3d)=p.(q.(x.1),q.(x.2),q.(x.3)) +proc map_apply(q:proc,p:proc,x:tuple4d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4)) +proc map_apply(q:proc,p:proc,x:tuple5d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5)) +proc map_apply(q:proc,p:proc,x:tuple6d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6)) +proc map_apply(q:proc,p:proc,x:tuple7d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6),q.(x.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type():test "Number of dimensions does not match" => 'false +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)=p.(q.(x.1,y.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.1,y.1),q.(x.2,y.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=p.(q.(x.1,y.1,z.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7)) + +proc scan(p:proc,x:tuple1d)=x.1 +proc scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)] +proc scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)] where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +proc pre_scan(p:proc,x:tuple1d,x0)=x0 +proc pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1] +proc pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)] +proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +type empty_head is unique + +proc head(x:null)=empty_head +proc head(x:tuple)=x.1 + +proc tail(x:null)=null +proc tail(x:tuple1d)=null +proc tail(x:tuple2d)=[x.2] +proc tail(x:tuple3d)=[x.2,x.3] +proc tail(x:tuple4d)=[x.2,x.3,x.4] +proc tail(x:tuple5d)=[x.2,x.3,x.4,x.5] +proc tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6] +proc tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7] + +proc prepend(y,x:null)=[y] +proc prepend(y,x:tuple1d)=[y,x.1] +proc prepend(y,x:tuple2d)=[y,x.1,x.2] +proc prepend(y,x:tuple3d)=[y,x.1,x.2,x.3] +proc prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4] +proc prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5] +proc prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6] +proc prepend(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => 'false + +proc append(x:null,y)=[y] +proc append(x:tuple1d,y)=[x.1,y] +proc append(x:tuple2d,y)=[x.1,x.2,y] +proc append(x:tuple3d,y)=[x.1,x.2,x.3,y] +proc append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y] +proc append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y] +proc append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y] +proc append(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => 'false + +proc elems(x:tuple1d)=x.1 +proc elems(x:tuple2d)=x.1,x.2 +proc elems(x:tuple3d)=x.1,x.2,x,3 +proc elems(x:tuple4d)=x.1,x.2,x.3,x.4 +proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 +proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 +proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 + +proc replace(x:tuple1d,y:'1,z)=[z] +proc replace(x:tuple2d,y:'1,z)=[z,x.2] +proc replace(x:tuple3d,y:'1,z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:'1,z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:'1,z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:'1,z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:'1,z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:'2,z)=[x.1,z] +proc replace(x:tuple3d,y:'2,z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:'2,z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:'2,z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:'2,z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:'2,z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:'3,z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:'3,z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:'3,z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:'3,z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:'3,z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:'4,z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:'4,z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:'4,z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:'4,z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:'5,z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:'5,z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:'5,z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:'6,z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:'6,z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:'7,z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or '1)=[x] +proc spread(x,y:tuple2d or '2)=[x,x] +proc spread(x,y:tuple3d or '3)=[x,x,x] +proc spread(x,y:tuple4d or '4)=[x,x,x,x] +proc spread(x,y:tuple5d or '5)=[x,x,x,x,x] +proc spread(x,y:tuple6d or '6)=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or '7)=[x,x,x,x,x,x,x] + +proc +(x:tuple(num),y:tuple(num))=map($+,x,y) +proc -(x:tuple(num),y:tuple(num))=map($-,x,y) +proc *(x:tuple(num),y:tuple(num))=map($*,x,y) +proc /(x:tuple(num),y:tuple(num))=map($/,x,y) +proc **(x:tuple(num),y:tuple(num))=map($**,x,y) +proc mod(x:tuple(num),y:tuple(num))=map($mod,x,y) +proc +(x:tuple(num),y:num)=map_const($+,x,y) +proc -(x:tuple(num),y:num)=map_const($-,x,y) +proc *(x:tuple(num),y:num)=map_const($*,x,y) +proc /(x:tuple(num),y:num)=map_const($/,x,y) +proc **(x:tuple(num),y:num)=map_const($**,x,y) +proc mod(x:tuple(num),y:num)=map_const($mod,x,y) +proc max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y) +proc min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y) +proc max(x:tuple(real_num))=reduce($max,x) +proc min(x:tuple(real_num))=reduce($min,x) +proc sum(x:tuple(num))=reduce($+,x) +proc prod(x:tuple(num))=reduce($*,x) +proc sint(x:tuple(num))=map($sint,x) +proc int(x:tuple(num))=map($int,x) +proc sreal(x:tuple(num))=map($sreal,x) +proc real(x:tuple(num))=map($real,x) + +proc string(x:tuple1d)="[ "++x.1++" ]" +proc string(x:tuple2d)="[ "++x.1++", "++x.2++" ]" +proc string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]" +proc string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]" +proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]" +proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" +proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + +// ***************************************************** +// LISTS +// ***************************************************** + +type _list_node(H,T) is struct{_head:H,_tail:T} +type list(T) is _list_node(T,T or _list_node(T,list(T))) +type _list_end is unique + +proc _cons(a,b)=new _list_node{_head=a,_tail=b} + +proc list(a)<>=_cons(a,_list_end) +proc list(a,arg...)<>=_cons(a,list(arg...)) + +proc reduce(p,a:_list_node)=p.(a._head,reduce(p,a._tail)) +proc reduce(p,a:_list_node(,_list_end))=a._head + +proc map(p,&a:_list_node){p.(a._head);map(p,a._tail)} +proc map(p,&a:_list_node(,_list_end)):p.(a._head) + +proc map(p,&a:_list_node(,_list_node),b:_list_node(,_list_node)){p.(&a._head,b._head);map(p,&a._tail,b._tail)} +proc map(p,&a:_list_node(,_list_end),b:_list_node(,_list_end)):p.(&a._head,b._head) +proc map(p,&a:_list_node,b:_list_node): test "List lengths do not match"=>'false + +proc map_const(p,&a:_list_node(,_list_node),b){p.(&a._head,b);map_const(p,&a._tail,b)} +proc map_const(p,&a:_list_node(,_list_end),b):p.(&a._head,b) + +proc PM__assign(&a:list,b:list):map($PM__assign,&a,b) +proc PM__assign(&a:list,b):map_const($PM__assign,&a,b) + +proc map(p,a:_list_node)=_cons(p.(a._head),map(p,a._tail)) +proc map(p,a:_list_node(,_list_end))=_cons(p.(a._head),_list_end) + +proc map(p,a:_list_node(,_list_node),b:_list_node(,_list_node))=_cons(p.(a._head,b._head),map(p,a._tail,b._tail)) +proc map(p,a:_list_node(,_list_end),b:_list_node(,_list_end))=_cons(p.(a._head,b._head),_list_end) +proc map(p,a:_list_node,b:_list_node)=_cons(p.(a._head,b._head),_list_end) check "List lengths do not match"=>'false + +proc [](a:list,b:fix int)=_list_elem(a,b,1) +proc _list_elem(a:_list_node(,_list_node),b:fix int,c:fix int) { + const d + if '(b==c) { + d=a._head + } else { + d=_list_elem(a,b,c+1) + } + return d +} +proc _list_elem(a:_list_node(,_list_end),b:fix int,c:fix int) { + test "List element out of range"=>a==b + return a._head +} + +// ***************************************************** +// RANGES AND SEQUENCES +// ***************************************************** + +// Not in operator +proc notin(x,y)=not(x in y) + +// not inc operator +proc notinc(x,y)=not(x inc y) + +// Treat null as empty sequence in some cases +proc in(x,y:null)='false +proc in(x:null,y:null)='true + +// Range base type (might later expand to interface) +type range_base is real_num + +// Single point sequence +type single_point(t:range_base) is rec {_t:t} +proc single_point(x)=new single_point { + _t=x +} +proc low(x:single_point)=x._t +proc high(x:single_point)=x._t +proc step(x:single_point)=x._t +proc width(x:single_point)='1 +proc norm(x:single_point)=x +proc #(x:single_point)=shape(['0..'0]) +proc _shp(x:single_point)='0..'0 +proc dims(x:single_point)=['1] +proc size(x:single_point)='1 +proc +(x:single_point,y:range_base)=new single_point { + _t=x._t+y +} +proc -(x:single_point,y:range_base)=new single_point { + _t=x._t-y +} +proc _arb(x:single_point)=x._t +proc in(x:range_base,y:single_point)=x==y._t +proc inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t +proc convert(x:single_point,y:range_base)=single_point(convert(x._t,y)) +proc sint(x:single_point)=single_point(sint(x._t)) +proc int(x:single_point)=single_point(int(x._t)) +proc sreal(x:single_point)=single_point(sreal(x._t)) +proc real(x:single_point)=single_point(real(x._t)) +proc #(x:single_point,y:index)='0 +proc #(x:single_point,y:grid_slice_dim)='0..'0 +proc #(x:single_point,y:single_point)='0..'0 +proc #(x:grid_slice_dim,y:single_point)=single_point(xx) where xx=x#y._t +proc overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1) +proc overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1) +proc overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1) +proc overlap(x:single_point(any_int),y:single_point(any_int))=overlap(x,y),overlap(y,x) +proc overlap(x:grid_slice_dim,y:single_point(any_int))=overlap(x,y),overlap(y,x) +proc overlap(x:single_point(any_int),y:grid_slice_dim)=overlap(x,y),overlap(y,x) +proc intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1) +proc intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1) +proc intersect(x:single_point(any_int),y:single_point(any_int))=x._t..if(x._t==y._t=>x._t,x._t-1) +proc element(x:single_point,y:index)=x._t +proc element(x:single_point,y:subs)=x._t..x._t +proc element(x,y:single_point)=element(x,y._t) +proc string(x:single_point)=string("single "++x._t) + +// Range types +type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} +proc ..(x:range_base,y:range_base)=new range { +_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:range)=x._lo +proc high(x:range)=x._hi +proc step(x:range)=convert(1,x._lo) +proc width(x:range)='1 +proc norm(x:range)=x +proc #(x:range(int))=shape([0..x._n-1]) +proc dims(x:range(int))=[x._n] +proc size(x:range(int))=x._n +proc +(x:range,y:range_base)=new range { + _lo=x._lo+y,_hi=x._hi+y,_n=x._n +} +proc -(x:range,y:range_base)=new range { + _lo=x._lo-y,_hi=x._hi-y,_n=x._n +} +proc _arb(x:range)=low(x) +proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi +proc convert(x:range,y:range_base)=new range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n +} +proc sint(x:range)=new range { + _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n +} +proc int(x:range)=new range { + _lo=int(x._lo),_hi=int(x._hi),_n=x._n +} +proc sreal(x:range)=new range { + _lo=sreal(x._lo),_hi=sreal(x._hi) +} +proc real(x:range)=new range { + _lo=real(x._lo),_hi=real(x._hi),_n=x._n +} +proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi +proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) +proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st +proc element(x:range(any_int),y:null)=x +proc element(x:range(any_int),y:grid_dim)=y+x._lo +proc #(y:range(any_int),x:int)=int(x-y._lo) +proc #(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #(y:range(any_int),x:strided_range_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #(y:range(any_int),x:strided_range_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #(y:range(any_int),x:stride(int))=_intseq(0,size(y),int(x._st)) +proc #(y:range(any_int),x:null)=0..size(y) +proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) +proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo +proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi +proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi +proc empty(x:range)=new range { + _lo=x._hi,_hi=x._lo,_n=0 +} +proc string(x:range)=string(x._lo)++".."++(x._hi) +// Cyclic range types (limited functionality and not part of grid) +type cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int} +proc cyclic_range(x:int,y:int,w:int)=new cyclic_range { +_lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:cyclic_range)=x._lo +proc high(x:cyclic_range)=x._hi +proc size(x:cyclic_range)=x._n +proc element(x:cyclic_range,y:int)=(x._lo + y) mod x._w +proc string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")" +// Strided range types +type strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int} +type _any_seq(t:range_base):iterable is strided_range(t), ... +type _any_seq(t:any_int) is ..., range(t) +type seq(t:range_base) is _any_seq(t) +proc _seq(lo,hi,st)=new strided_range { +_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) +proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) +proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y +proc _intseq(x:int,y:int,st:int)= new strided_range { +_lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) +proc low(x:strided_range)=x._lo +proc high(x:strided_range)=x._hi +proc step(x:strided_range)=x._st +proc size(x:strided_range)=x._n +proc width(x:strided_range)='1 +proc norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)='0 +proc #(x:strided_range)=shape([0..x._n-1]) +proc dims(x:strided_range)=[x._n] +proc +(x:strided_range,y:range_base)=new strided_range { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n +} +proc -(x:strided_range,y:range_base)=new strided_range { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n +} +proc _arb(x:seq)=x._lo +proc convert(x:strided_range,y:range_base)=new strided_range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n +} +proc sint(x:strided_range)=new strided_range { + _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n +} +proc int(x:strided_range)=new strided_range { + _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n +} +proc sreal(x:strided_range)=new strided_range { + _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n +} +proc real(x:strided_range)=new strided_range { + _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n +} +proc in(x:int,y:strided_range(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:strided_range(int),y:strided_range(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:strided_range(int),y:range(int) or single_point(int))=x inc low(y)..high(y) by 1 +proc #(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #(y:seq,x:range)=y#x._lo..y#x._hi +proc #(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #(y:seq,x:range_below)=0..y#x._t +proc #(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #(y:seq,x:strided_range_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:strided_range_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:stride)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:null)=0..size(y)-1 +proc string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st +proc element(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:strided_range,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:strided_range,y:strided_range(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:strided_range,y:null)=x +proc overlap(x:strided_range(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:strided_range(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:strided_range(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x) +PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" +proc intersect(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +_lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc overlap(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc empty(x:strided_range(any_int))=new strided_range { + _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 +} +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=new block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #(x:block_seq)=shape([0..x._n-1]) +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=new block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=new block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:grid_dim){ + var a=array(0,#x) + forall i in a,j in x:i=j + return new map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=new map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +} +proc map_seq(x:map_seq)=x +proc #(x:map_seq)=#(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=new map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=new map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=new map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=new map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=new map_seq { + array=a[ns] + } + w=new map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=new map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return new map_seq { + array=a + } +} +// Grids (tuples of sequences) +type _grid_dim(t:range_base) is seq(t),... +type _grid_dim(t:int) is ...,block_seq,map_seq +type grid_dim(t:range_base) is _grid_dim(t) +type grid1d(t1:grid_dim) is [t1] +type grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2] +type grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is [t1,t2,t3] +type grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is [t1,t2,t3,t4] +type grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim) is [t1,t2,t3,t4,t5] +type grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim) is [t1,t2,t3,t4,t5,t6] +type grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim,t7:grid_dim) is [t1,t2,t3,t4,t5,t6,t7] +type grid(t:range_base) is tuple(grid_dim(t)) +proc #(x:grid)=shape(map($_shp,x)) +proc dims(x:grid)=map($_size,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($+,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:grid_dim,y:grid_dim){ + var a=array(0,#y) + forall i in a,j in y:i=x[j] + return new map_seq{ + array=a + } +} +proc element(x:grid,y:grid)=map($element,x,y) +// Slices of grids (may have dims that are just an integer and also _ or _() or null) +type grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null +type grid_slice(t) is grid(t),tuple(grid_slice_dim(t)) +// Some limited functionality for extended grids (which include cyclic ranges) +type iterable_dim is grid_slice_dim,cyclic_range,... +type iterable_grid is tuple(iterable_dim),grid_slice +proc _shp(x:iterable_dim)=0..size(x)-1 +proc size(x:iterable_dim)->(int)... +proc element(x:iterable_dim,y)=error_type()check "Cannot index this type with a non-integer index"=>'false +proc element(x:iterable_dim,y:int)->(any)... +proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) +proc _shp(x:stretch_dim)=null +proc _shp(x:null)=x +proc _size(x:stretch_dim or null)='1 +proc _size(x)=size(x) +PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" +proc _act(x)=x +proc _sliceit(arg...)=tuple(arg...) +proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) +proc active_dims(x:single_point)=null +PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _act(x,y)=y +proc active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y) +proc active_dims(x:single_point,y)=null +proc _ar(x:single_point)=0 +proc _ar(x)=1 +proc rank(x:iterable_grid)=map_reduce($_ar,$+,x) +proc element(x:iterable_grid,y:index){ + t=_tup(y) + return _ges(head(x),tail(x),head(t),tail(t),'false) +} +proc element(x:grid_slice,arg...:grid_slice){ + t=_tup(arg...) + return _ges(head(x),tail(x),head(t),tail(t),'true) +} + +proc element(x:null,y)=null +proc _spnt(i,y:'true)=i +proc _spnt(i,y:'false)=i._t +proc _spif(i:int,y:'true)=single_point(i) +proc _spif(i,y:'true)=i +proc _spif(i,y:'false)=i +proc _ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => 'false +proc _ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:'true)=prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:'false)=_ges(head(x),tail(x),head(y),tail(y),t) +proc _ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t) +proc _ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j:empty_head,y,t)=null +proc _ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => 'false +proc _ges(i:null,x,j:empty_head,y,t:'true)=error_type() :test "Rank mismatch" => 'false +proc _ges(i:null,x,j:empty_head,y,t:'false)=null +proc size(x:iterable_grid)=map_reduce($_size,$*,x) +proc #(x:grid_slice)=shape(map($_shp,active_dims(x))) +proc dims(x:iterable_grid)=map($_size,active_dims(x)) +proc _arb(x:grid_slice)=map($_arb,x) +proc in(x:tuple(range_base),y:grid_slice)=map_reduce($in,$and,x,y) +proc inc(x:grid_slice,y:grid_slice)=map_reduce($inc,$and,x,y) +proc #(x:grid,y:tuple(subs_dim))=map($#,x,y) +PM__intrinsic _acthash(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _acthash(x,y)=x#y +proc #(x:grid_slice,y:tuple(subs_dim) or grid_slice)=map_apply($_acthash,$_sliceit,x,y) +proc convert(x:grid_slice,y:real_num)=map_const($convert,x,y) +proc sint(x:grid_slice)=map($sint,x) +proc int(x:grid_slice)=map($int,x) +proc sreal(x:grid_slice)=map($sreal,x) +proc real(x:grid_slice)=map($real,x) +proc low(x:grid_slice)=map($low,x) +proc high(x:grid_slice)=map($high,x) +proc overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y) +proc overlap(x:grid_slice,y:grid_slice)=u,v where u,v=map($overlap,x,y) +proc intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y) +proc intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y)) +proc expand(x:grid_slice,y:grid)=map($expand,x,y) +proc contact(x:grid_slice,y:grid)=map($contract,x,y) +PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" +// ***************************************************** +// SHAPES +// ***************************************************** +type extent is tuple(range(int) ),extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d +type extent1d is tuple1d_of(range(int)) +type extent2d is tuple2d_of(range(int)) +type extent3d is tuple3d_of(range(int)) +type extent4d is tuple4d_of(range(int)) +type extent5d is tuple5d_of(range(int)) +type extent6d is tuple6d_of(range(int)) +type extent7d is tuple7d_of(range(int)) +type mshape(extent_t:extent) is rec {use _extent:extent_t,_n:int,_o:int} +type mshape1d is mshape(extent1d) +type mshape2d is mshape(extent2d) +type mshape3d is mshape(extent3d) +type mshape4d is mshape(extent4d) +type mshape5d is mshape(extent5d) +type mshape6d is mshape(extent6d) +type mshape7d is mshape(extent7d) +// Create array, vector and matrix shapes +proc _low(x)=low(x) +proc _low(x:null)='0 +proc _off(x)=-index(dims(x),map($_low,x)) +proc PM__array(arg...)=shape(map($_extnt,[arg...])) +proc _extnt(n:any_int)=0..int(n)-1 +proc _extnt(n:null)=null +proc _extnt(n:range(any_int))=int(n) +proc shape(extent:extent)=new mshape { + _extent=extent,_n=size(extent),_o=_off(extent) +} +// Conforming mshapes +proc check_conform(x,y) { + check_conform(#x,#y) +} +proc check_conform(x:mshape,y:mshape) { + test "Mshapes "++x++" and "++y++" do not conform"=>conform(x,y) +} + +proc _conform(x,y)=size(x)==size(y) +proc _conform(x:null,y)=size(y)=='1 +proc _conform(x,y:null)='true +proc _conform(x:null,y:null)='true +proc conform(x:mshape,y:mshape)=map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0check "Values of different ranks cannot conform"=>rank(x)==rank(y) +// Local size of a mshape +proc _local_size(x:mshape)=size(x._extent) +// Convert an extent to have a zero base +proc zero_base(x:range)=0..size(x)-1 +proc zero_base(x:extent)=map($zero_base,x) +// Extent of a mshape +proc extent(x:shape)=x._extent +// Dimensions of a mshape +proc dims(x:mshape)=map($size,x._extent) +// Size from dimensions +proc size(x:tuple(int))=reduce($*,x) +// Empty mshape +proc _empty(x)=1..0 +proc empty(x:extent)=map($_empty,x) +// Slice of mshape +proc [](x:mshape,s:index)=x._extent[s] +proc [](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,'true))):check_contains(x,s) +// ***************************************************** +// INDEXING AND SLICING +// ***************************************************** +// Generic types supporting indexing and mapping +type iterable is iterable_grid,grid_slice,grid,grid_slice_dim,cyclic_range,array,... +proc [](x:iterable,arg...){ + d=#x + y=_tup(arg...) + check_contains(d,y) + return element(x,fill_in(d,y,'false)) +} +// Index type +type index is any_int,tuple(any_int) +// Slice and subscript types +type range_below(x) is rec {_t:x} +type range_above(x) is rec {_t:x} +type strided_range_below(x) is rec {_t:x,_st:x} +type strided_range_above(x) is rec {_t:x,_st:x} +type stride(x) is rec {_st:x} +type slice_dim is range(any_int),strided_range(any_int),range_above(any_int), range_below(any_int),strided_range_above(any_int),strided_range_below(any_int), stride(any_int),null,stretch_dim +type slice is slice_dim,tuple(slice_dim) +type subs_dim is slice_dim,any_int +type subs is index,slice,subs_dim,tuple(subs_dim) +// Partial ranges/sequences mainly used in subscripts +proc ..._(x)=new range_below { + _t=x +} +proc _...(x)=new range_above { + _t=x +} +proc by(x:range_base)=new stride { + _st=x +} +proc by(x:range_above(),y)=new strided_range_above { + _t=x._t,_st=convert(y,x._t) +} +proc by(x:range_below(),y)=new strided_range_below { + _t=x._t,_st=convert(y,x._t) +} +proc string(x:range_above)=x._t++"..." +proc string(x:range_below)="..."++x._t +proc string(x:strided_range_above)=x._t++"... by"++x._st +proc string(x:strided_range_below)="..."++x._t++"by "++x._st +proc string(x:stride)="by "++x._st +proc low(x:range_above)=x._t +proc low(x:strided_range_above)=x._t +proc high(x:range_below)=x._t +proc high(x:strided_range_below)=x._t +proc step(x:range_above or range_below)='1 +proc step(x:strided_range_above or strided_range_below)=x._st +proc width(x:strided_range_above or strided_range_below or range_above or range_below)='1 +// Stretch dimension in subscript +type stretch_dim is unique{PM__strdim} +proc string(x:stretch_dim)="_" +proc size(x:stretch_dim)='1 +proc expand(x:stretch_dim,y:grid)=x +proc contract(x:stretch_dim,y:grid)=x +proc in(x:stretch_dim,y)='true +proc inc(x:stretch_dim,y)='true +proc convert(x:stretch_dim,y:range_base)=x +proc #(x:stretch_dim,y:index)='0 +proc #(x:stretch_dim,y:grid_slice_dim)='0..'0 +proc intersect(x:stretch_dim,y:grid_slice_dim)=y +proc intersect(x:grid_slice_dim,y:stretch_dim)=x +proc intersect(x:stretch_dim,y:stretch_dim)=x +proc overlap(x:grid_slice_dim,y:stretch_dim)=#x +proc overlap(x:stretch_dim,y:grid_slice_dim)='0..'0 +proc overlap(x:stretch_dim,y:stretch_dim)='0..'0 +// Check subscript is in range +proc check_contains(a:extent,arg...) { + test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...) +} +proc check_contains(a:mshape,arg...) { + check_contains(a._extent,arg...) +} +proc check_contains(a,arg...) { + check_contains(#a,arg...) +} +proc check_contains(a:dshape,arg...) { + check_contains(a._mshape._extent,arg...) +} +proc _contains(x:null,y)='true +proc _contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y) +proc _contains(x:range(int),y:range(any_int) or seq(any_int))=_contains(x,y._lo) and _contains(x,y._hi) or y._lo>y._hi +proc _contains(x:range(int),y:range_below(any_int) or strided_range_below(any_int) or range_above(any_int) or strided_range_above(any_int))=_contains(x,y._t) +proc _contains(x:range(int),y:stride(any_int))='true +proc _contains(x:range(int),y:null)='true +proc contains(x:mshape1d,y:subs_dim)=_contains(x.1,y) +proc contains(x:extent,y:tuple(subs_dim))=map_reduce($_contains,$and,x,y) +PM__intrinsic _rgd(x:stretch_dim)->(PM__tinyint) : "miss_arg" +proc _rgd(x)=x +proc _rigid_dims(x:grid_slice or tuple(subs_dim))=map_apply($_rgd,$_sliceit,x) +proc contains(x:extent,y:tuple(subs_dim) and contains(stretch_dim))=contains(x,_rigid_dims(y)) +proc contains(x:extent,y,arg...)=contains(x,[y,arg...]) +// Complete a subscript using a base mshape +proc fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => 'false +proc fill_in(x:seq(int) or null,y:any_int,t:'true)=single_point(int(y)) +proc fill_in(x:seq(int) or null,y:any_int,t:'false)=int(y) +proc fill_in(x:seq(int) or null,y:any_int,t:null)=int(y)..int(y) +proc fill_in(x:seq(int) or null,y:range(any_int),t)=int(y) +proc fill_in(x:seq(int) or null,y:strided_range(any_int),t)=int(y) +proc fill_in(x:seq(int),y:range_below(any_int),t)=x._lo..int(y._t) +proc fill_in(x:seq(int),y:range_above(any_int),t)=int(y._t)..x._hi +proc fill_in(x:seq(int),y:strided_range_below(any_int),t)=lo..int(y._t) by y._st where lo=y._t-(y._t-x._lo)/y._st*y._st +proc fill_in(x:seq(int),y:strided_range_above(any_int),t)=int(y._t)..x._hi by y._st +proc fill_in(x:seq(int),y:stride(any_int),t)=x by int(y._st) +proc fill_in(x:seq(int) or null,y:null,t)=x +proc fill_in(x:grid,y:tuple(any_int),t)=int(y) +proc fill_in(x:grid,y:tuple(subs_dim),t)=map($fill_in,x,y,spread(t,x)) +proc fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim),t)=_fill_in(x,head(y),tail(y),t) +proc _fill_in(x,y,z,t)=prepend(fill_in(x.1,y,t),_fill_in(tail(x),head(z),tail(z),t)) +proc _fill_in(x,y:stretch_dim,z,t:'true)=prepend(null,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x,y:stretch_dim,z,t:'false)=prepend(y,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x:null,y:empty_head,z,t)=null +proc _fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x:empty_head,y,z,t)=error_type() :test "Rank mismatch in slice" => 'false +// ******************************************************* +// SUBSCRIPT INTERSECTION AND ALIASING +// ******************************************************* +// Test for intersection between two subscripts +proc intersects(x:null,y:subs_dim)='true +proc intersects(x:subs_dim,y:null)='true +proc intersects(x:null,y:null)='true +proc intersects(x:range(any_int),y:range(any_int))=not(x._hiy._hi) +proc intersects(x:seq(any_int),y:seq(any_int))=size(intersect(x,y))>0 +proc intersects(x:range(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._hi>=y._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range(any_int))=y._hi>=x._t +proc intersects(x:range(any_int),y:range_below(any_int) or strided_range_below(any_int))=x._lo<=y._t +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range(any_int))=y._lo<=x._t +proc intersects(x:strided_range(any_int),y:range_above(any_int) or strided_range_above(any_int))=intersects(y._t..x._hi by step(y),x) +proc intersects(y:range_above(any_int) or strided_range_above(any_int),x:strided_range(any_int))=intersects(y._t..x._hi by step(y),x) +proc intersects(x:strided_range(any_int),y:range_below(any_int) or strided_range_below(any_int))=intersects(x,y._t..x._lo by -step(y)) +proc intersects(y:range_below(any_int) or strided_range_below(any_int),x:strided_range(any_int))=intersects(x,y._t..x._lo by -step(y)) +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._t>=y._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_below(any_int) or strided_range_below(any_int))=y._t>=x._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_above(any_int) or strided_range_above(any_int))='true +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_below(any_int) or strided_range_below(any_int))='true +proc intersects(x:strided_range_below(any_int),y:strided_range_above(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 +proc intersects(y:strided_range_above(any_int),x:strided_range_below(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 +proc intersects(x:strided_range_above(any_int),y:strided_range_above(any_int))=abs(x._t-y._t) mod gcd(int(x._st),int(y._st))==0 +proc intersects(x:strided_range_below(any_int),y:strided_range_below(any_int))=abs(x._t-y._t) mod gcd(abs(int(x._st)),abs(int(y._st)))==0 +proc intersects(x:stride(any_int),y:subs_dim)='true +proc intersects(x:subs_dim,y:stride(any_int))='true +proc intersects(x:stride(any_int),y:stride(any_int))='true +proc intersects(x:seq,y:int)=y in x +proc intersects(x:int,y:seq)=x in y +proc intersects(x:int,y:int)=x==y +proc intersects(x:int,y:range_above(any_int))=x>=y._t +proc intersects(x:int,y:range_below(any_int))=x<=y._t +proc intersects(x:int,y:strided_range_above(any_int))=x>=y._t and (x-y._t) mod y._st==0 +proc intersects(x:int,y:strided_range_below(any_int))=x<=y._t and (y._t-x) mod y._st==0 +proc intersects(y:range_above(any_int),x:int)=x>=y._t +proc intersects(y:range_below(any_int),x:int)=x<=y._t +proc intersects(y:strided_range_above(any_int),x:int)=x>=y._t and (x-y._t) mod y._st==0 +proc intersects(y:strided_range_below(any_int),x:int)=x<=y._t and (y._t-x) mod y._st==0 +proc _intersects(x,y,z:'true)=map_reduce($intersects,$and,x,y) +proc _intersects(x,y,z:'false)='false +proc intersects(x:tuple(subs_dim except stretch_dim),y:tuple(subs_dim except stretch_dim))=_intersects(x,y,rank(x)==rank(y)) +proc intersects(x:tuple(subs_dim),y:tuple(subs_dim))=_intersects(rx,ry,rank(rx)==rank(ry))where rx=_rigid_dims(x),ry=_rigid_dims(y) +proc intersects(x:tuple(subs_dim),y:null)='true +proc intersects(x:null,y:tuple(subs_dim))='true +proc _intersects(x:subs,y:subs)=intersects(x,y) +proc _intersects(x,y)='false +// Alias checking +proc PM__check_alias(arg...)=false +proc PM__check_alias(i,j,x,y) { + test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) +} +proc PM__check_alias(i,j,x,y,arg...) { + if _intersects(x,y):PM__check_alias(i,j,arg...) +} +// Combining subscripts +proc PM__cmbidx(x,y)=_cmb(x,y) +proc PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...) +type _cmb_error is unique +proc _cmb(x,y)=_cmb_error +proc _cmb(x:subs except index,y:subs)=_cmb1(x,y) +proc _cmb1(x,y)=_cmb_error +proc _cmb1(x:subs_dim,y:subs_dim)=x[y] +proc _cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y)) +proc _cmb2(x,y,z:'true)=x[y] +proc _cmb2(x,y,z:'false)=_cmb_error +// ******************************************************* +// ITERATION - SEQUENTIAL AND CONCURRENT +// ******************************************************* +// Iteration over mshape +// - first element +proc PM__first(d:int)=0,null,d>0 +proc PM__first(d:tuple1d)=i,s,e where i,s,e=PM__first(d.1) +proc PM__first(d:tuple2d)=[j1,j2],[s1,s2],e1 and e2 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2) +proc PM__first(d:tuple3d)=[j1,j2,j3],[s1,s2,s3],e1 and e2 and e3 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3) +proc PM__first(d:tuple4d)=[j1,j2,j3,j4],[s1,s2,s3,s4],e1 and e2 and e3 and e4 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4) +proc PM__first(d:tuple5d)=[j1,j2,j3,j4,j5], [s1,s2,s3,s4,s5],e1 and e2 and e3 and e4 and e5 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5) +proc PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],[s1,s2,s3,s4,s5,s6],e1 and e2 and e3 and e4 and e5 and e6 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6) +proc PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],[s1,s2,s3,s4,s5,s6,s7],e1 and e2 and e3 and e4 and e5 and e6 and e7 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7) +// - subsequent elements +proc PM__next(d:int,g,i)=ii,null,ii> _doloop(int)->(int) : "do_loop" +PM__intrinsic<> _doloop(int,int)->(int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int)->(int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int)->(int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int)->(int,int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int,int)->(int,int,int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "do_loop" +proc _elts(x:int)=i where i=_doloop(x) +proc _elts(x:tuple1d)=[i] where i=_elts(x.1) +proc _elts(x:tuple2d)=[i,j] where i,j=_doloop(x.1,x.2) +proc _elts(x:tuple3d)=[i,j,k] where i,j,k=_doloop(x.2,x.2,x.3) +proc _elts(x:tuple4d)=[i,j,k,l] where i,j,k,l=_doloop(x.1,x.2,x.3,x.4) +proc _elts(x:tuple5d)=[i,j,k,l,m] where i,j,k,l,m=_doloop(x.1,x.2,x.3,x.4,x.5) +proc _elts(x:tuple6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_doloop(x.1,x.2,x.3,x.4,x.5,x.6) +proc _elts(x:tuple7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7) +PM__intrinsic<> _blockedloop(any)->(int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int,int) : "blocked_loop" +proc _belts(x,y:shape1d)=[i] where i=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape2d)=[i,j] where i,j=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape3d)=[i,j,k] where i,j,k=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape4d)=[i,j,k,l] where i,j,k,l=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape5d)=[i,j,k,l,m] where i,j,k,l,m=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y)) +PM__else +proc PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n) +proc PM__generate(x:mshape,n,s)=_elts(dims(x),1,n) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=_iota(siz,0,x-1,1,tot) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +PM__endif +PM__intrinsic _indices(any)->(int) : "indices" +// ************************************** +// ARRAYS +// ************************************** +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,'true) +type farray(e,d:shape) is e^const d,e^invar d,e^fix d,array_template(e,d,'false) +type farray(e,d:mshape) is ...,array_slice(e^const any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix any) +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif +PM__intrinsic<> _array(x:any,y:any,z:any,v:'false)->(PM__dim x,y) : "array" +PM__intrinsic<> _array(x:any,y:any,z:any,v:'true)->(PM__vdim x,y) : "var_array" +PM__intrinsic<> _redim(x:any^any,y:any)->(over x,y) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(PM__dim x,y) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(#x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(%x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + +proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) +PM__intrinsic _make_subref(a:any^mshape,i:int)->(%a) : "make_rf" +PM__intrinsic _get_aelem(x:any^any,y:int)->(%x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +// Linear index of tuple mshape (zero base,unit stride) +proc _indx(g:null,s)='0 +proc _indx(g:range(int),s)=int(s) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:null)='1 +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _offset(x:mshape)=x._o +proc _offset(x)='0 +proc index(g:mshape1d or tuple1d_of(int),s:any_int)=int(_indx(g.1,s))+_offset(g) +proc index(g:mshape1d or tuple1d_of(int),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g) +proc index(g:mshape2d or tuple2d_of(int),s:tuple2d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2))+_offset(g) +proc index(g:mshape3d or tuple3d_of(int),s:tuple3d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3)))+_offset(g) +proc index(g:mshape4d or tuple4d_of(int),s:tuple4d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4))))+_offset(g) +proc index(g:mshape5d or tuple5d_of(int),s:tuple5d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5)))))+_offset(g) +proc index(g:mshape6d or tuple6d_of(int),s:tuple6d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6))))))+_offset(g) +proc index(g:mshape7d or tuple7d_of(int),s:tuple7d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7))))))))+_offset(g) +proc index2point(i:int,s:range(int))=[i+s._lo] +proc index2point(i:int,s:int)=[i] +proc index2point(i:int,s:tuple1d_of(int))=[i] +proc index2point(i:int,s:tuple2d_of(int))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc index2point(i:int,s:tuple3d_of(int))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple4d_of(int))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple5d_of(int))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple6d_of(int))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple7d_of(int))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} +// ***************************************** +// ARRAY TEMPLATES +// ***************************************** +// Array templates +type array_template(a,d:mshape or dshape,v:fix bool) is rec {_a:a,_d:d,_s:int,_v:v} +proc array(a:any,s:dshape)=new array_template { + _a=a,_d=s,_s=s._size,_v='false +} +proc array(a:any,s:mshape(tuple(range(int))))=new array_template { + _a=a,_d=s,_s=size(s),_v='false +} +proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) +proc varray(a:any,s:mshape or dshape)=new array_template { + _a=a,_d=s,_s=size(s),_v='true +} +proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) +proc _zero(x)=0 +proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) +// Treat a template as if it were an array +proc _arb(a:array_template)=a._a +proc #(a:array_template(,mshape,))=a._d +proc dims(a:array_template(,mshape,))=dims(a._d) +proc size(a:array_template)=a._s +proc redim(a:array_template,d:mshape)= new array_template { +_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s +proc element(a:array_template,arg...:subs)=a._a +// Array creation from template +proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) +proc PM__dup(a:array_template(,shape,'true))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) +proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),'false) +// ***************************************** +// MATRIX AND VECTOR +// ***************************************** +type matrix_element is num,bool,... +type _matrix(t) is struct{use array:t} +type matrix(t:matrix_element) is _matrix(array(t,shape2d)) +type vector(t:matrix_element) is _matrix(array(t,shape1d)) +type matrix_template(t:matrix_element) is _matrix(array_template(t,shape2d)) +type vector_template(t:matrix_element) is _matrix(array_template(t,shape1d)) +proc PM__matrix(x)=new _matrix{ + array=x +} +proc vector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n)) +proc vvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n)) +proc dvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) +proc dvvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) +proc vector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(array(x,n,distr)) +proc vvector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(varray(x,n)) +proc matrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n)) +proc vmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n)) +proc dmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) +proc dvmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) +proc matrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(array(x,n,distr)) +proc vmatrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(varray(x,n)) +proc matrix_element_zero(x:num)=convert(0,x) +proc matrix_element_balance(x:num,y:num)=xx,yy where xx,yy=balance(x,y) +proc matrix_element_add(x:num,y:num)=x+y +proc matrix_element_subtract(x:num,y:num)=x-y +proc matrix_element_multiply(x:num,y:num)=x*y +proc matrix_element_zero(x:bool)=false +proc matrix_element_balance(x:bool,y:bool)=x,y +proc matrix_element_add(x:bool,y:bool)=x or y +proc matrix_element_multiply(x:bool,y:bool)=x and y +proc +(x:matrix,y:matrix) { + check_conform(x.array,y.array) + test "Cannot add zero size matrices"=>size(x)>0 + var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_add(xx,yy) return z +} +proc -(x:matrix,y:matrix) { + check_conform(x.array,y.array) + test "Cannot add zero size matrices"=>size(x)>0 + var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_subtract(xx,yy) return z +} +proc *(x:matrix,y:matrix) { + sx=#x + sy=#y + sz=[sx.1,sy.2] + test "Matrices do not conform for multiplication"=>size(sx.2)==size(sy.1) + test "Cannot multiply zero size matrices"=>size(x)>0 and size(y)>0 + var z=matrix(b,sz) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for *i in sz,zz in z.array { + var s=matrix_element_zero(_arb(z.array)) + foreach invar k in #(sx.1) { + s=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2])) + } + zz=s + } + return z +} + +// ***************************************** +// DISTRIBUTED SHAPE (DSHAPE) +// ***************************************** +type _distrb(extent:extent,dist:distr or null) +type _distrb(extent:extent,dist:distr) is ...,dshape(extent,dist) +type _distrb(extent:extent,dist:null) is ...,mshape(extent) +type shape(extent:extent,dist:distr or null) is _distrb(extent,dist) +type shape1d(extent:extent1d,dist:distr or null) is shape(extent,dist) +type shape2d(extent:extent2d,dist:distr or null) is shape(extent,dist) +type shape3d(extent:extent3d,dist:distr or null) is shape(extent,dist) +type shape4d(extent:extent4d,dist:distr or null) is shape(extent,dist) +type shape5d(extent:extent5d,dist:distr or null) is shape(extent,dist) +type shape6d(extent:extent6d,dist:distr or null) is shape(extent,dist) +type shape7d(extent:extent7d,dist:distr or null) is shape(extent,dist) +type PM__distr_tag is unique +type dshape(extent:extent,dist:distr) is rec {use _mshape:mshape(extent),dist:dist,_tile,_tilesz,_size:int,_level:int,_dtag:PM__distr_tag} +proc check_conform(x:dshape,y:mshape) { + check_conform(x._mshape,y) +} + +proc check_conform(x:mshape,y:dshape) { + test "A distributed object connot conform to a non-distributed value" => 'false +} + +proc check_conform(x:dshape,y:dshape) { + check_conform(x._mshape,y._mshape) + test "Objects have different distributions"=> x.dist==y.dist +} + +proc conform(x:dshape,y:mshape)=conform(x._mshape,y) +proc conform(x:mshape,y:dshape)='false +proc conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist +proc _local_size(x:dshape)=size(x._tile) +// Get an element from a null tile - just pass index through +proc element(x:null,y:tuple(index))=y +proc element(x:null,y:int)=y +proc size(d:dshape)=d._size +proc dims(d:dshape)=dims(d._mshape._extent) +proc #(d:dshape)=new dshape{ + _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level,_dtag=d._dtag +} +proc [](d:dshape,s:index)=d._mshape._extent[s] +proc [](d:dshape,s:subs)=_dshape_slice(d,ss) where ss=fill_in(#d._mshape._extent,s,'true){ + check_contains(#(d._mshape._extent),s) +} + +proc _dshape_slice(d:dshape,ss)=new dshape{ +_mshape=shape(#active_dims(ss)),dist=dist,_tile=tile,_tilesz=#tile,_size=size(tile),_level=d._level,_dtag=d._dtag} where tile=element(dist,_shrd_node()) where dist=sliced_distr(d.dist,ss) +// ***************************************** +// DISTRIBUTED ARRAY AND SHAPE TEMPLATES +// ***************************************** +type darray_template(e,d,p,t) is rec {_e:e,_d:d,_p:p,_t:t,_v} +type dshape_template(d,p,t) is rec {_d:d,_p:p,_t:t} +proc darray(e,d:extent)=array(e,d,VBLOCK) +proc array(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { + _e=e,_d=d,_p=distr,_t=topo,_v='true +} +proc array(e,d:extent,distr:null or tuple(null))=array(e,d) +proc dvarray(e,d:extent)=varray(e,d,VBLOCK) +proc varray(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { + _e=e,_d=d,_p=distr,_t=topo,_v='true +} +proc varray(e,d:extent,distr:null or tuple(null))=varray(e,d) +proc shape(d:extent,distr,topo:any=null)=new dshape_template { + _d=d,_p=distr,_t=topo +} +// ***************************************** +// DISTRIBUTED ARRAYS +// ***************************************** +proc PM__dup(d:darray_template) { + dd=dims(d._d) + topo=topology(d._t,d._p,dd, min(size(d._d),shrd_nnode())) + dist=distribute(d._p,dd,topo) + test "Not enough processors to implement distribution"=> size(#dist)<=shrd_nnode() + p=_shrd_node() + var elem=empty(dist) + if p size(#dist)<=shrd_nnode() + p=_shrd_node() + var elem=empty(dist) + if p 'false +proc _arb(dd:any^dshape)=_get_aelem(dd,0) +proc dims(dd:any^dshape)=dims((#dd)._mshape) +proc PM__redim(a,d)=_redim(a,d) +proc PM__local(a:any^dshape)=_redim(a,(#a)._tilesz) +proc PM__local(a:any^mshape)=a +proc PM__local%(x:shared) shared =PM__local(x) +proc element(a:any^dshape,t) { + p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) + var r=_arb(a) + if p==_this_node():r=_get_aelem(a,i) + _bcast_shared(&r,p) + return r +} + +proc _set_elem(&a:any^dshape,v,t) { + p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) + if p==_this_node():PM__setaelem(&a,i,v) +} + +// ************************************************* +// SLICES +// ************************************************* +// Slices +type array_slice(a,s) is struct^{_a:a,_s:s} +proc _arb(x:array_slice)=_arb(x._a) +proc #(x:array_slice)=#(x._s) +proc #(x:array_slice(any^dshape))=_dshape_slice(d,d._mshape._extent#x._s) where d=#(x._a) +proc conform(x:mshape,y:array_slice)=map_reduce($_conform,$and,x,y._s) +proc conform(x:dshape,y:array_slice)=map_reduce($_conform,$and,x._mshape,y._s) +proc conform(x,y:array_slice)=map_reduce($_conform,$and,#x,y._s) +proc dims(x:array_slice)=dims(x._s) +proc size(x:array_slice)=size(x._s) +proc element(x:array_slice(any^mshape,),y:index)=element(x._a,x._s[y]) +proc element(x:array_slice,y:subs)=new array_slice { + _a=x._a,_s=x._s[y] +} +proc _set_elem(&x:array_slice(any^mshape,),v,y:index) { + PM__setaelem(&^(x._a),index(#(x._a),x._s[y]),v) +} +proc PM__dup(x:array_slice(any^mshape,)){ + var a=array(_arb(x),#x) + a=x + return a +} +proc PM__dup(x:array_slice(any^dshape,)){ + d=#x._a + ss=(#x._a)._mshape#x._s + var a=array(_arb(x._a),_dshape_slice(d,ss)) + _set_slice(&^(PM__local(a)),#(#a)._tile, PM__local(x._a),overlap((#x._a)._tile,ss)) + return a +} +// ************************************************* +// ARRAY & SLICE ASSIGNMENT +// ************************************************* +proc PM__assign(&xx:farray,x:any) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign(&xx:farray,x:array) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign(&xx:varray,x:any except varray) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign(&xx:varray,x:farray) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign_var(&xx:farray,x:any) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign_var(&xx:farray,x:array) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign_var(&xx:varray,x:any except varray) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign_var(&xx:varray,x:farray) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__aliased_assign(&xx,x){ +} +proc PM__aliased_assign(&xx:array_slice,x:array_slice) <> { + _assign_internal_slice(&xx,x._s) +} +proc _array_assign(&xx,x,v:'false){ + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc _array_assign(&xx,x,v:'true){ + check_conform(extent(#xx),extent(#x)) + if _copy_array(&xx,x):_sync_messages(xx,x) +} +proc _array_assign(&xx:array_slice,x:array_slice,v:'true){ + check_conform(extent(#xx),extent(#x)) + if _copy_array(&xx,x):_sync_messages(xx,x) +} +proc _array_assign(&xx:varray,x,v:'true) { + _assign_element(&xx,x) +} +proc _array_assign(&xx:varray,x:array_template,v:'true) { + _assign_element(&xx,PM__dup(x)) +} +PM__if_compiling +proc _set_slice(&x,a,y,b) { + foreach i in a,j in b:x[i]=y[j] +} +PM__else +proc _set_slice(&x,a,y,b) { + if size(a)>0:forall i in a,j in b{ + sync x[i]=y[j] + } +} +PM__endif +type _non_d is any^mshape,array_slice(any^mshape,) +proc _set_array(&x:any^mshape,y){ + forall i in x { + _assign(&i,y) + } +} + +proc _set_array(&x:any^dshape,y){ + _set_array(&^(PM__local(^(&x))),y) +} +proc _set_array(&x:array_slice(any^mshape,),y){ + forall i in x._s { + _set_elem(&x._a,y,i <>) + } +} +proc _set_array(&x:array_slice(any^dshape,),y){ + tile=(#x._a)._tile + t=overlap(tile,((#x._a)#x._s)) + forall i in t { + _set_elem(&x._a,y,i <>) + } +} + +proc _copy_array(&a:_non_d,b:_non_d){ + forall i in a, j in b { + i=j + } + return 'false +} +proc _copy_array(&xx:any^dshape,x:_non_d) { + tile=(#xx)._tile + forall i in tile { + PM__setaelem(&xx,index(dims(tile),here),x[(#x)[i]] <>) + } + return 'false +} +proc _copy_array(&xx:array_slice(any^dshape,),x:_non_d) { + tile=(#xx._a)._tile + subtile,subarray=overlap(tile,(#xx._a)._mshape#xx._s) + forall i in subtile,j in subarray { + PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <>) + } + return 'false +} + +proc _copy_array(&a:_non_d,x:any^dshape) { + dist=(#x).dist + foreach p in #(dist) { + tile=element(dist,p) + i=index(dims(dist),p) + if i==_shrd_node() { + forall kk in PM__local(x),j in tile { + var k=kk + _bcast_shared(&k,i) + _set_elem(&a,k,(#a)[j] <>) + } + } else { + forall j in tile { + var k=_arb(a) + _bcast_shared(&k,i) + _set_elem(&a,k,(#a)[j] <>) + } + } + } + return 'false +} + +proc _copy_array(&v:_non_d,x:array_slice(any^dshape,)) { + dist=(#(x._a)).dist + xs=(#(x._a))._mshape#x._s + nodes=#dist + foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) { + p=nodes[pp] + utile,elem=overlap(dist[nodes[p]],xs) + i=index(dims(dist),p) + if i==_shrd_node() { + forall j in utile, jj in elem { + var k=element(PM__local(x._a),j) + _bcast_shared(&k,i) + _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>) + } + } else { + forall j in elem { + var k=_arb(x._a) + _bcast_shared(&k,i) + _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>) + } + } + } + return 'false +} + +proc _copy_array(&x:any^mshape,y:array_template) { + _set_array(&x,y._a) + return 'false +} +proc _copy_array(&x:any^dshape,y:array_template) { + _set_array(&^(PM__local(^(&x))),y._a) + return 'false +} +type _comp is contains(array or *any or ^*(,,,,)) +proc _copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) { + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#(xx._a),xd=#(x._a) + return 'true +} + +proc _copy_array(&xx:any^dshape,x:array_slice(any^dshape)) { + _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#xx,xd=#(x._a) + return 'true +} + +proc _copy_array(&xx:array_slice(any^dshape,),x:any^dshape) { + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#(xx._a),xd=#x + return 'true +} + +proc _copy_array(&xx:any^dshape,x:any^dshape) { + _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#xx,xd=#x + return 'true +} + +proc _assign_internal_slice(&xx:array_slice(any^mshape),s) { + x=new array_slice{ + _a=xx._a,_s=s + } + xx=x +} +proc _assign_internal_slice(&xx:array_slice(any^dshape),s) { + xxd=#(xx._a) + xxs=xxd._mshape#xx._s + xs=xxd._mshape#s + ltile=intersect(xxd._tile,xs) + ls=#ltile + var x=array(_arb(xx),ls) + _set_slice(&x,ls,PM__local(xx._a),overlap(xxd._tile,ltile)) + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxs, x,xxd,xxd._mshape#s,ltile) +} + +proc _copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) { + _push_node_dist() + oldpart,oldtile=overlap(xs,oldd._tile) + newpart,newtile=overlap(xxs,newd._tile) + if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { + p=index(dims(oldd.dist),pp) + if p/=_this_node() { + tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) + ov=overlap(newd._tile,tile) + if size(ov)>0:_recv_slice(p,&xx,ov) + } + } + if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { + p=index(dims(newd.dist),pp) + if p/=_this_node() { + tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) + ov=overlap(otile,tile) + if size(ov)>0:_send_slice(p,x,ov) + } + } + if size(newpart)>0 and size(oldpart)>0 { + oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) + _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) + } + PM__pop_node(newd) +} + +proc _copy_darray_slice(&xx:_comp^any,newd,xxs,x,oldd,xs,otile) { + _push_node_dist() + oldpart,oldtile=overlap(xs,oldd._tile) + newpart,newtile=overlap(xxs,newd._tile) + if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { + p=index(dims(newd.dist),pp) + if p/=_this_node() { + tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) + ov=overlap(otile,tile) + if size(ov)>0:_send_slice(p,x,ov) + } + } + if size(newpart)>0 and size(oldpart)>0 { + oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) + _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) + } + if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { + p=index(dims(oldd.dist),pp) + if p/=_this_node() { + tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) + ov=overlap(newd._tile,tile) + if size(ov)>0:_recv_slice_sync(p,&xx,ov) + } + } + PM__pop_node(newd) +} + +proc _xp(x:single_point,y)=single_point(low(y)) +proc _xp(x,y)=y +// ************************************************* +// REFERENCES (SUBSCRIPTS AND SLICES) +// ************************************************* +// Reference type for & args +type PM__reftype(x) is x,^shared(x,,,,) +// Support for internal ^(...) reference type +PM__intrinsic _v1(x:any)->(PM__d1 x) : "elem"(1) +PM__intrinsic _v2(x:any)->(PM__d2 x) : "elem"(2) +PM__intrinsic _v3(x:any)->(PM__d3 x) : "elem"(3) +PM__intrinsic _v4(x:any)->(PM__d4 x) : "elem"(4) +PM__intrinsic _v5(x:any)->(PM__d5 x) : "elem"(5) +PM__intrinsic _v1%(r:any,s:any,h:any,x:any)->(PM__d1% x) : "elem"(1) +PM__intrinsic _v2%(r:any,s:any,h:any,x:any)->(PM__d2% x) : "elem"(2) +PM__intrinsic _v3%(r:any,s:any,h:any,x:any)->(PM__d3% x) : "elem"(3) +PM__intrinsic _v4%(r:any,s:any,h:any,x:any)->(PM__d4% x) : "elem"(4) +PM__intrinsic _v5%(r:any,s:any,h:any,x:any)->(PM__d5% x) : "elem"(5) +// Right hand side references +proc _make_null(x)=null +proc PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>'false +proc PM__subref(x,t:subs){ + tt=_tup(t) + check_contains(#x,tt) + return _subref(x,tt) +} +proc PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x)) +proc PM__subref(x:^*(,,,,),t:null)=PM__subref(x,map($_make_null,#_v1(x))) +proc _subref(x:any^mshape,t:index)=element(x,t) +proc _subref(x:any^any,t:subs)=new array_slice { + _a=x,_s=fill_in(#x,t,'true) +} +proc _subref(x:array_slice(any^mshape,),t:index)=element(x._a,x._s[t]) +proc _subref(x:array_slice,t:subs)=new array_slice { + _a=x._a,_s=x._s[t] +} +proc _subref(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) +proc _subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t]) +proc _subref(a:^*(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc _subref(a,t)=$[](a,t) +proc [](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...))) +// Left hand side references +proc PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>'false +proc PM__sublhsamp(x,t:subs) { + tt=_tup(t) + check_contains(#x,tt) + return _sublhs(x,tt) +} +proc PM__sublhsamp(x:any^dshape,t:subs) { + test "Cannot have subscript of a distributed array in ""&"" argument"=>'false + return _arb(x) +} + +proc PM__sublhs(x,t)=error_type() check "Incorrect type in subscript"=>'false +proc PM__sublhs(x,t:subs) { + tt=_tup(t) + check_contains(#x,tt) + return _sublhs(x,tt) +} +proc PM__sublhs(x:^!(,,,,),t:subs) { + tt=_tup(t) + return _sublhs(x,tt) +} +proc PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x)) +proc PM__sublhs(x:^!(,,,,),t:null)=PM__sublhs(x,map($_make_null,#_v1(x))) +proc _sublhs(x:any^mshape,t:index)=_make_subref(x,t) +proc _sublhs(x:any^any,t:subs)=new array_slice { + _a=x,_s=fill_in(#x,t,'true) +} +proc _sublhs(x:array_slice(any^mshape,),t:index)=_make_subref(x._a,x._s[t]) +proc _sublhs(x:array_slice,t:subs)=new array_slice { + _a=x._a,_s=x._s[t] +} +proc _sublhs(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) +proc _sublhs(a:^!(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc [](&a:array,v,arg...){ + PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v) +} + +// Realise a reference +proc PM__valref(x)=x +proc PM__valref(x:^*(,,,,)) { + var v=_v1(x) + if _v4(x)==_shrd_node() { + v=_getref(x,null) + } + _bcast_shared(&v,_v4(x)) + return v +} + +// Assign to a reference +proc PM__assign(&x:^*(,,,,),y) { + check_assign_types(_v1(^(&x)),y) + if _v4(^(&x))==_shrd_node() { + PM__assign(&^(_getlhs(^(&x),null)),y) + } +} + +proc PM__assign(&x:^*(,,,,),y,p:assignment_operator) { + if _v4(^(&x))==_shrd_node() { + PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) + } +} + +// ************************************************************* +// DISTRIBUTED REFERENCES +// ************************************************************* +// Distributed reference is an internal compiler type +// ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode) +// mode is: +// null -- local reference +// _s_ref -- shrd index on darray, only shrd/indexed otherwise +// _sp_ref -- shrd index on darray, some priv after (or before) +// _d_ref -- indexed index on darray, shrd/indexed otherwise +// _dp_ref -- indexed index on darray, some priv after (or before) +// _p_ref -- priv index on darray and possibly elsewhere +type _s_ref is unique +type _sp_ref is unique +type _d_ref is unique +type _dp_ref is unique +type _p_ref is unique +PM__intrinsic _import_dref%(r:any,s:any,h:any,x:any)->(^^x) : "import_dref" +// Some trivial referencing cases +proc PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t) +proc PM__sublhsamp%(x:any^dshape,t:subs) { + test "Cannot have subscript of a distributed array in ""&"" argument"=>'false + return _arb(x) +} + +proc PM__sublhs%(x,y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv ^*(,,,,),y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>'false +proc PM__subref%(x:priv,y)=PM__subref(x,y) +proc PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y) +proc PM__subref%(x:priv,y:invar indexed)=PM__subref(x,*y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:index)=PM__subref(x,y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:subs)=PM__subref(x,y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:invar indexed)=PM__subref(x,_dmap(y,here)) +proc PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>'false +proc PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y) +proc PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y) +proc PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y)) +// Reference of non-distributed array with priv or indexed subscript +proc PM__subref%(x:invar any^mshape,t:index){ + tt=_tup(t) + check_contains(#x,tt) + i=index(#x,tt) + return PM__dref(_get_aelem(x,i),x,i,null,null) +} +proc PM__subref%(x:invar any^mshape,t:subs){ + tt=_tup(t) + check_contains(#x,tt) + return PM__drefs(x,x,tt,null,null) +} +proc PM__subref%(x:invar any^mshape,t:invar indexed)=PM__subref%(x,_dmap(t,here)) +proc PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t]) +proc PM__subref%(x,t)=PM__dref($[](x,t),x,t,null,null) +// Subscript or slice of distributed array +proc PM__subref%(x:shared any^dshape,t:invar index) complete <>{ + tt=_tup(t) + check_contains(#(x),tt) + return PM__dref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) +} +proc PM__subref%(x:shared any^dshape,t:index){ + tt=_tup(t) + check_contains(#(x),tt) + return PM__dref(_arb(x),x,i,p,_p_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) +} +proc PM__subref%(x:shared any^dshape,t:subs){ + tt=_tup(t) + check_contains(#(x),tt) + var xx=varray(_arb(x),empty(#x)) + return PM__drefs(xx,x,tt,p,_p_ref) where p=nodes_for_grid((#x).dist,tt) +} +proc PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t) +proc PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond { + check_contains(#x,_dmap(t,here)) + return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t) +} +proc PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t) +// Subscript or slice of non-distristuted array which is itself result of variant slice +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + i=index(#(_v1%(x)),tt)return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){ + tt=_tup%(t) + check_contains(#_v1%(x),tt) + i=index(#(_v1%(x)),tt) + return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) { + tt=_tup(t) + check_contains(#(_v1%(x)),tt) + return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +// Subscript or slice of darray which is itself the result of a priv subscript +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt) +} +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:subs){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) where p=nodes_for_grid((#_v1%(x)).dist,tt) +} +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +// Subscript of a priv slice +proc PM__subref%(x:priv ^#(,,,null,null),t:subs)=PM__subref%(_v2%(x),_v3%(x)[_tup(t)]) +proc PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)=PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here) +// Subscript of distributed reference +proc _arb%(x:partial)=_arb(x) +proc _arb%(x:complete) complete <>=_arb(x) +proc _arb%(x:chan) complete <>=_arb(x) +proc _arb%(x:invar) complete <>=_arb(x) +proc PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref) +proc PM__subref%(x:priv ^*(any^any,,,,),t:invar indexed)=PM__subref%(x,_dmap(_tup(t),here)) +proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref) +// Node .[] subscript of distributed array +type _lcl is unique{_LCL} +proc PM__nodelhs%(x,y)=PM__noderef%(x,y) +proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)=^(PM__import_val(PM__local(x)),coherent) +proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(region:dshape,x:shared any^dshape,y:priv any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)where p=index(xd,y) +} +proc PM__noderef%(region:dshape,x:shared any^dshape,y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:invar any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:priv any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x,y)=error_type() { + if not region is { + test """.[]"" subscript in non-distributed region"=>'false} elseif x is { + test """.[]"" subscript cannot be applied to a mirrored array"=>'false} elseif not x is { + test """.[]"" subscript applied to a non-array"=>'false} elseif not y is { + test """.[]"" subscript must have an integer value"=>'false} else { + test "Incorrect "".[]"" subscript"=>'false + } +} + +// May need to cap off reference with here +type _here(t) is rec {here:t} +proc _cap%(x,h)<>=x +proc _cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here { + here=h +} +) +proc _capn%(x,h)<>=PM__dref(_v1%(x),x,new _here { + here=h +} +) +// Treat ! variables differently only for limited circumstances in drefs +proc _drat(at,tile,t)='false +proc _drat(at:'true,tile:tuple(range or block_seq),t:indexed and _dr)='true +type _di(n) is indexed_dim('1,'1,,n) or int +type _dr is [_di('1)],[_di('1),_di('2)],[_di('1),_di('2),_di('3)],[_di('1),_di('2),_di('3),_di('4)],[_di('1),_di('2),_di('3),_di('4),_di('5)],[_di('1),_di('2),_di('3),_di('4),_di('5),_di('6)],[_di('1),_di('2),_di('3),_di('4),_di('5),_di('6),_di('7)] +// Resolve a distributed reference +proc PM__getref%(x,at)=x +proc PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x) +proc PM__getref%(x:priv ^*(,,,int,_p_ref),at) { + PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) + return v +} +proc PM__getref%(x:priv ^*(,,,int,_sp_ref),at) { + PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) + return v +} +proc _scatter(x,region) { + if _this_node()==_v4(x):foreach node in #region.dist { + d=#region._mshape + a={ + _getref(_import_dref%(x),j): j in d + } + p=index(dims(region.dist),node) + _send_slice(p,a,region.dist[node]) + } +} + +proc PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> { + chan var xx=_v1%(x) + _getref_s%(&xx!,^^(x),at) + _bcast_shared(&xx) + return xx +} +proc _getref_s%(&xx:invar,x:invar,at:invar) PM__node { + PM__head_node{ + _irecv(_v4(x),&xx) + } + _scatter(x,region) + _sync_messages(xx,x) +} +proc PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{ + chan var xx=_v1%(x) + _getref_sc%(&xx!,^^(x),at) + _bcast_shared(&xx) + return xx +} +proc _getref_sc%(&xx:invar,x:invar,at:invar) PM__node { + _scatter(x,region) + PM__head_node{ + _recv(_v4(x),&xx) + } + _sync_messages(xx,x) +} +proc PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> { + chan var a=_v1%(x) + _getref_d%(&^(PM__local%(^(&a!))),^^(x),at <>) + _bcast_shared(&a) + return a +} + +proc _getref_d%(&a:invar,x:invar,at:invar) PM__node { + _get_dindex_from_dref(&a,x,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) +} +proc PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> { + chan var a=_arb(_v2%(x)) + _getref_dc%(&a!,^^(x),at <>) + _bcast_shared(&a) + return a +} +proc _getref_dc%(&a:invar,x:invar,at:invar) PM__node { + PM__head_node{ + _get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) + } +} + +proc PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> { + chan var a=_v1%(x) + _getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>) + _bcast_shared(&a) + return a +} +proc _getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node { + PM__head_node{ + _get_dindex_from_ref(&a,x,t.2, _local_region(region._tile,subregion(schedule)),region, t.1,atq,_drat(at,region._tile,t.1)) + } +} +proc PM__getref%(x:priv ^#(,,,,),at) { + var v=varray(_arb(_v1%(x)),#_v3%(x)) + var vv=varray(_arb(_v1%(x)),empty(#_v1%(x))) + foreach p in _v4%(x) { + dist=(#(_getref(_v2%(x),null))).dist + u=overlap(_v3%(x),dist[p]) + ppp=index(dims(dist),p) + PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null) + v[u]=vvv + } + return v +} + +// Resolve reference locally (once communicated) +proc _getref_elem(x:any^mshape,i)=_get_aelem(x,i) +proc _getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i) +proc _getref(x:^*(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x)) +proc _getref(x:^*(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here) +proc _getref(x:^*(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)] +proc _getref(x:^*(,,null,,),y)<>=_getref(_v2(x),y) +proc _getref(x:^*(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y)) +proc _getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x) +proc _getref(x:^shared(,null,null,null,null),y)<>=_v1(x) +proc _getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x)) +proc _getslice(x:any^dshape,tt) { + t=overlap((#x)._tile,tt) + var v=varray(_arb(x),#t) + v=PM__local(x)[t] + return v +} +proc _getslice(x:any^mshape,t) { + var v=varray(_arb(x),#t) + v=x[t] + return v +} +proc _getref(x:any^any,y)=x +proc _getref(x:^shared(,,indexed,,),y)<>=_getref(_v2(x),y)[_dmap(_v3(x),y)] +proc _getref(x:^shared(,any^dshape,indexed,,),y)<>=element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) :test "Internal error - uncapped dref" => 'false +PM__if_compiling +PM__intrinsic _sync%(any,any,any,&x:any): "sync" +PM__else +proc _sync%(&x:any){ +} +PM__endif +// Assignment of distributed and/or shared or uniform references +proc PM__assign%(&x:priv,y,at) { + _sync%(&x) + PM__assign(&x,y <>) +} +proc PM__assign%(&x:invar,y,at) { + _sync%(&x) + _assign_to_invar%(&x,y) +} +proc _assign_to_invar%(&x:uniform,y:invar) complete { + PM__assign(&x,y <>) +} + +proc _assign_to_invar%(&x:shared,y:invar) shared{ + PM__assign(&x,y) +} + +proc _assign_to_invar%(&x:invar,y:priv) { + test "Can only assign an ""invar"" value to an ""invar"" variable" => 'false +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,'false { + test "Cannot assign element twice in same assignment"=> _getref(xx,null)==yy + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y) + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y,at) { + foreach invar p in 0..size(#region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + } + foreach invar p in 0..size(#region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + test "Cannot assign an element two different values in a single assignment"=> _getref(xx,null)==yy + } + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,at) { + _sync%(&x) + var xx=_import_dref%(x) + PM__assign(&^(_getlhs(^(&xx),here)),y) +} +proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,at) { + _sync%(&x) + PM__assign(&^(_v1%(^(&x))),y) +} +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,'false { + test "Cannot assign element to two different values in same assignment"=> _getref(xx,null)==yy + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:invar,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y)) + } +} + +proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) { + _set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)), $_just_assign,^^(^??),at,_v4(x) <>) +} +proc _just_assign(x,y)=y +proc _set_ref_dp%(&x:invar,y:invar, prc:invar,atq:invar,at:invar,t:invar) PM__node { + _set_dindex_of_ref(&x,y,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,prc,atq,at) +} + +// Operater assignment: x =y +proc PM__assign%(&x:priv,y:priv,pr,at) { + PM__assign(&x,y,pr) +} +proc PM__assign%(&x:priv,y:invar,pr,at) { + PM__assign(&x,y,pr) +} +proc PM__assign%(&x:invar,y,pr,at) { + _assign_to_invar%(&x,y,pr,at) +} + +proc _assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete{ + PM__assign(&x,y,pr <>) +} + +proc _assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared { + PM__assign(&x,y,pr) +} + +proc _assign_to_invar%(&x:invar,y:priv,pr,at){ + _assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at) +} +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,pr,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) { + foreach invar p in 0..size(region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,pr,at) { + var xx=_import_dref%(x) + PM__assign(&^(_getlhs(^(&xx),here)),y,pr) +} +proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,pr,at) { + PM__assign(&^(_v1%(^(&x))),y,pr) +} +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:priv,pr,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) { + _set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,pr,^^(^??),at <>)where t=_v4%(x) +} +// Resolve LHS reference (locally after communication) +proc _getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here) +proc _getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:^(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:^shared(,,null,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:^shared(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:^(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _getlhs(x:^shared(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t)) +proc _getlhs(x:^#(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:^#shared(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x) +proc _getlhs(x:^shared(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:^(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:any^any,y)=x +proc _getlhs(x:any^dshape,y)=PM__local(x) +proc _getlhs(x:^shared(,,indexed,,),y)<>=_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y)) +proc _getlhs(x:^shared(,any^dshape,indexed,,),y)<>=_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getlhs(x:^shared(,,indexed,,),y:null)=_v1(x) :test "Internal error -- uncapped indexed ref" => 'false +// ************************************************************** +// INDEXED VARIABLES +// ************************************************************** +type indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m='1,_c:c='0,_d:d='1,_n:n} +type indexed(t:int) is tuple(indexed_dim or int) except tuple(int) +proc PM__makeidxdim(x:null,y)=new indexed_dim { + _n=y +} +proc PM__makeidxdim(x:null)=new indexed_dim { + _n=null +} +proc PM__makeidxdim(x:range,y)=new indexed_dim { + _c=x._lo,_n=y +} +proc PM__makeidxdim(x:strided_range,y)=new indexed_dim { + _c=x._lo,_m=x._st,_n=y +} +proc PM__makeidxdim(x,y)=PM__makeidxdim(get_dim(x,y),y) +proc PM__makeidxdim(x:tuple)=map($PM__makeidxdim,x,indices(x)) +proc PM__makeidxdim(x:seq)=[PM__makeidxdim(x,'1)] +proc PM__makeidx(x:indexed_dim or indexed)=new _indexed { + _t=_tup(x),_r=null +} +proc PM__makeidx(x:indexed_dim or indexed,y)=new _indexed { + _t=_tup(x),_r=y +} +proc PM__makeidx(x,y)=x :test "Malformed indexed expression" => 'false +proc PM__makeidx(x)=x :test "Malformed indexed expression" => 'false +proc *%(x:indexed)=_dmap(x,here) +proc *%(x)=here check"""*"" operator can only be applied to an ""indexed"" value"=>'false +proc *(x)=x check"""*"" operator cannot be applied outside of a parallel context"=>'false +proc +(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc +(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc -(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c-y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc -(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=-x._m,_c=-x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc *(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) +proc *(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) +proc /(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c,_d=x._d*y,_n=x._n} where y=int(yy) +proc +(x:indexed_dim,y:indexed_dim)=new indexed_dim { + _m=x._m*y._d+y._m*x._d,_c=x._c*y._d+y._c*x._d,_d=x._d*y._d,_n=x._n +} +proc -(x:indexed_dim,y:indexed_dim)=new indexed_dim { + _m=x._m*y._d-y._m*x._d,_c=x._c*y._d-y._c*x._d,_d=x._d*y._d,_n=x._n +} +proc string(x:indexed_dim)="($here."++x._n++"*"++x._m++"+"++x._c++")/"++x._d +proc string(x:indexed_dim('1))="$here."++x._n++"*"++x._m++"+"++x._c +proc string(x:indexed_dim('1,'1))="$here."++x._n++"+"++x._c +proc string(x:indexed_dim('1,'1,'0))="$here."++x._n +proc _correct(x:indexed,y:extent)=map($-,x,low(y)) +proc _dmap(x:any_int,n:int)=x +proc _dmap(x:any_int,n:grid_slice_dim)=single_point(x) +proc _dmap(x:any_int,n:tuple(int))=x +proc _dmap(x:any_int,n:tuple(grid_slice_dim))=single_point(x) +proc _dmap(x:indexed_dim,n:int)=(n*x._m+x._c)/x._d +proc _dmap(x:indexed_dim,n:tuple)=_dmap(x,get_dim(n,x._n)) +proc _dmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi)where lo=_dmap(x,low(n)),hi=_dmap(x,high(n)) +proc _dmap(x:indexed_dim('1,'1),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st +proc _dmap(x:indexed_dim('1,'1),n:block_seq)=block_seq(n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) +proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)=map_const($_dmap,x,n) +proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)=s#map_const($_dmap,x,n) +type _round_up is unique +type _round_down is unique +proc _dunmap(x:indexed_dim,n:null)=null +proc _dunmap(x:indexed_dim,n:int,r:_round_down)=(n*x._d-x._c)/x._m +proc _dunmap(x:indexed_dim,n:int,r:_round_up)=(n*x._d+x._m-sign(1,x._m)-x._c)/x._m +proc _dunmap(x:indexed_dim,n:tuple)=_dunmap(get_dim(n,x._n),x) +proc _dunmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up) +proc _dun(x:indexed_dim,m,n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m))) +proc _dun(x:int,m,n:extent)=n +proc _dunmap(x:indexed,m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n) +proc _dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,n) +// Given tile and global region (which may be null) compute local region +proc _local_region(t,r:null)=t +proc _local_region(t,r)=intersect(t,r) +proc _root_node(at:'true)=_root_node() +proc _root_node(at:'false)=_this_node() +// Resolve x[indexed] +proc _get_dindex(&a,x,shapex,local_tile,local_region,t:indexed,at) { + tt=_correct(t,shapex._mshape) + if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) { + if at or a is <_comp^any> { + _get_dindex_ss(&a,x,shapex,local_tile,local_region,tt,at) + } else { + _get_dindex_s(&a,x,shapex,local_tile,local_region,tt,at) + } + } else { + if at or a is <_comp^any> { + _get_dindex_rs(&a,x,shapex,local_tile,local_region,tt,at) + } else { + _get_dindex_r(&a,x,shapex,local_tile,local_region,tt,at) + } + } +} + +// Resolve x[indexed] for cases where size(x[indexed])>=size(region) +// -- in this case send one value for every point in current (sub)region +proc _get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + PM__head_node{ + shapexx=#shapex._mshape + this_tile=shapex._tile + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(shapex.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) + } + } + } + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) + _sync_messages(a,x) + } +} + +// Resolve x[indexed] for cases where size(x[indexed])<=size(region) +// -- in this case send those values in x which are needed to calculate x[indexed] +proc _get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + shapexx=#shapex._mshape + src_range=_dmap(t,local_tile) + var b=array(_arb(a),#src_range) + foreach p in nodes_for_grid(shapex.dist,src_range) { + if contains(#(shapex.dist),p) { + i=index(dims(shapex.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(src_range,other_tile) + if size(portion_to_send)>0:_recv_slice(i,&b,active_dims(src_range,portion_to_send)) + } + } + } + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + src_range2=_dmap(t,other_tile) + portion_to_send=overlap(shapex._tile,src_range2) + if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) + } + } + } + u,v=overlap(src_range,shapex._tile) + forall i in u,j in v{ + _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) + } + _sync_messages(x,b) + _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) +} + +// Resolve x[indexed] for cases where size(x[indexed])>=size(region) +// -- in this case send one value for every point in current (sub)region +// -- Version for more complex types that need sync receive +proc _get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0 { + _recv_slice_sync(i,&a,portion_to_recv) + } + } + } + } + _sync_messages(a,x) +} + +// Resolve x[indexed] for cases where size(x[indexed])<=size(region) +// -- in this case send those values in x which are needed to calculate x[indexed] +// -- Version for more complex types that need sync receive +proc _get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) { + PM__head_node { + shapexx=#shapex._mshape + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + src_range=_dmap(t,other_tile) + portion_to_send=overlap(shapex._tile,src_range) + if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) + } + } + } + } + src_range=_dmap(t,local_tile) + var b=array(_arb(a),#src_range) + if _head_node() or at { + u,v=overlap(src_range,shapex._tile) + forall i in u,j in v { + _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) + } + foreach p in nodes_for_grid(shapex.dist,src_range) { + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(src_range,other_tile) + if size(portion_to_send)>0{ + PM__head_node{ + _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send)) + } + if at:_bcast_slice_shared(&b,active_dims(src_range,portion_to_send)) + } + } + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) + _sync_messages(x,b) +} + +proc _copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) { + u=overlap(a_tile,_dunmap(t,b_tile,a_extent)) + forall i in u { + j=b_tile#_dmap(t,a_tile[i]) + if j in #b_tile:_set_elem(&a,PM__getelem(b,j),i <>) + } +} + +proc _copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) { + u=intersect(a_tile,_dunmap(t,b_tile,a_extent)) + forall i in u { + bb=_import_dref%(b) + _set_elem(&a,_getref(bb,i),a_tile#i <>) + } +} + +// Resolve x[ indexed ][ indexed or shared ] ... +proc _get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) { + t=_correct(tt,shapex._mshape) + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) + } + } + } + nodes=nodes_for_grid(local_region.dist,dest_range) + var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) + foreach pp in #nodes { + p=nodes[pp] + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0 { + b[pp]={ + _getref(_import_dref%(x),h):h in portion_to_recv + } + _isend(i,b[pp]) + } + } + } + } + _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ indexed or shared ] ... +proc _get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) { + t=_correct(tt,shapex._mshape) + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + nodes=nodes_for_grid(local_region.dist,dest_range) + var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) + foreach pp in #nodes { + p=nodes[pp] + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0 { + b[pp]={ + _getref(_import_dref%(x),h):h in portion_to_recv + } + _isend(i,b[pp]) + } + } + } + } + _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0{ + PM__head_node{ + _recv_slice_sync(i,&a,portion_to_recv) + } + if at:_bcast_slice_shared(&a,portion_to_recv) + } + } + } + } + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ priv ] +proc _get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:indexed,complt,at) { + dest_range=_dmap(t,this_tile,#shapex._mshape) + foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt) + } + } + src_range=_dunmap(t,shapex._tile,local_region._mshape) + forall j in overlap(this_tile,src_range) { + jj=index(#this_tile,j) + PM__do_at size(this_tile),jj,aa,a,xx,x { + PM__assign(&aa,_getref(xx,null)) + } + } + foreach p in nodes_for_grid(local_region.dist,src_range) { + if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() { + PM__recv_req pp,xx,x,_getref(xx,null) + } + } + if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt) + } + } + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ whatever ] = priv +proc _set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed, pr:invar proc,complt:invar,at:invar) PM__node <>:_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at) +proc _set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed, pr:proc,complt,at) { + t=_correct(tt,shapex._mshape) + dest_range=_dmap(t,this_tile,#shapex._mshape) + PM__head_node{ + foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(shapex.dist),p) + if contains(#(shapex.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt) + } + } + } + src_range=_dunmap(t,shapex._tile,local_region._mshape) + for j in overlap(this_tile,src_range) { + jj=index(#this_tile,j) + PM__do_at size(this_tile),jj,yy,y,xx,x { + PM__assign(&^(_getlhs(xx,null)),yy,pr) + } + } + foreach p in nodes_for_grid(local_region.dist,src_range) { + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + PM__recv_assn pp,xx,yy,x,y,at{ + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } + } + } + _sync_messages(x,y) +} + +// ************************************************************** +// Envelope and stencil definitions +// ************************************************************** +type envelope is rec{cross:extent or null,corner:extent or null,envelope:extent} +proc ortho(x:extent)=new envelope { + cross=x,corner=spread(0..0,x),envelope=x +} +proc ortho(x:extent,y:extent)=new envelope { + cross=if(x inc y=>x,y),corner=y,envelope=envelope(x,y) +} +proc envelope(x:envelope)=x.envelope +proc envelope(x:extent)=x +proc envelope(x:any_int,y:any_int)=min(xx,yy)..max(xx,yy) where xx=int(x),yy=int(y) +proc envelope(x:any_int,y:seq(any_int))=envelope(x..x,y) +proc envelope(x:seq(any_int),y:any_int)=envelope(x,y..y) +proc envelope(x:seq(any_int),y:seq(any_int))=if(size(x)>0=>if(size(y)>0=>min(lx,ly)..max(hx,hy),lx..hx),if(size(y)>0=>0..0,ly..hy)) where lx=min(llx,hhx),ly=min(lly,hhy),hx=max(llx,hhx),hy=max(lly,hhy)where llx=int(low(x)),lly=int(low(y)),hhx=int(high(x)),hhy=int(high(y)) +proc envelope(x:tuple,y:tuple)=map($envelope,x,y) +proc envelope(x:null,y:extent)=y +proc envelope(x:extent,y:null)=x +proc envelope(x:extent or null,y:envelope)=envelope(x,y.envelope) +proc envelope(x:envelope,y:extent or null)=envelope(x.envelope,y) +proc envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope) +proc string(x:envelope)=string(x.cross++" ortho "++x.corner) +// ************************************************************** +// Support for nhd statement +// ************************************************************** +type _nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits} +type nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here} +proc PM__nhd%(x:invar envelope or extent,bound:invar) shared <>=new _nhd { +_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),_limits=_expand_limits(region._extent,envelope(x),bound)} where t=_get_halo(region,region._tile,envelope(x)) +proc PM__nhd%(x,bound:invar)=^(new _nhd { + _nbhd=n,_tile=t,_tilesz=#t,_interior=t,_limits=region._extent +} +,shared) where t=region._tile where n=xx where xx=spread(0..0,here){ + _check_nhd%(x) +} +proc _check_nhd%(n:invar envelope or extent) { +} +proc _check_nhd%(n:extent):test "Neighbourhood must be invar"=>'false +proc _check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>'false +proc PM__check_bounds%(b:invar boundary){ + _check_ranks(extent(region),b) +} +proc PM__check_bounds%(b:boundary):test "Bounds must be ""invar"""=>'false +proc PM__check_bounds%(b):test "Bounds must have a boundary type"=>'false +proc _check_ranks(n:tuple,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b)) +proc _check_ranks(n:envelope,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n.cross),rank(b)) +proc _check_ranks(n,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type('1,rank(b)) +proc _check_ranks(n,b){ +} +type boundary is boundary_dim,tuple(boundary_dim) +type boundary_dim is CYCLE,EXCLUDED,range(int),null +type CYCLE is unique +type EXCLUDED is unique +proc _expand_limits(t:range(int),n:range(int),b:boundary_dim)=t +proc _expand_limits(t:range(int),n:range(int),b:CYCLE)=_exterior(t,n) +proc _expand_limits(t:tuple,n:tuple,b:boundary_dim)=map($_expand_limits,t,n,spread(b,n)) +proc _expand_limits(t:tuple,n:tuple,b:tuple(boundary_dim))=map($_expand_limits,t,n,b) +proc PM__set_nhd%(&n,x:complete){ + n._array[n._nbhd._interior[n._index]]=x +} +proc PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]=x check "Expression in ""nhd"" must be ""complete"""=>'false +proc PM__nhd_join(x)=x._array +proc PM__nhd_join(x,y)=new _join{ + head=x,tail=y._array +} +proc PM__nhd_var%(x,n:_nhd,i,h)<>=new nbhd{ + _array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h +} +proc PM__nhd_active(region,nbhd,bound:null)=region._extent +proc PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound) +proc PM__nhd_active(region,nbhd,bound){ + r=PM__nhd_active(region,nbhd,spread(bound,region._extent)) + return r +} +proc _nhd_active(r,n,b:CYCLE or null)=r +proc _nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b)) +proc _nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n) +proc _make_nhd%(x:invar,d:invar) shared <>{ + var v=array(x,d) + return v +} +proc PM__set_edge%(&x,y,z){ +} +proc PM__subref(x:nbhd,t:subs)=_nhd_sub(x,t) +proc PM__subref(x:nbhd,t:null)=_nhd_sub(x,t) +proc _nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))=PM__subref(x._array,tt+x._nbhd._interior[x._index]) { + tt=_tup(t) + test "Subscript"++tt++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),"At "++x._here++" nhd "++tt++" goes outside of boundary "++limits=>contains(limits,dtt) where limits=x._nbhd._limits where dtt=tt+x._here +} + +proc _nhd_sub(x:nbhd,t)=_arb(x._array)check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>'false +proc PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>'false +proc envelope(x:_nhd)=envelope(x._nbhd) +proc envelope(x,y:_nhd)=envelope(x,y._nbhd) +proc envelope(x:_nhd,y:_nhd)=envelope(x._nbhd,y._nbhd) +type _join is struct^{head,tail} +proc PM__blocking%(x:null){ +} +proc PM__blocking%(x):test "Block expression must be tuple of integers"=>'false +proc PM__blocking%(x:tuple(any_int)){ + test "Rank of ""block="" does not match region"=>same_type(rank(x),rank(region)) + test "Block sizes must be positive"=>map_reduce($_positive,$and,x) +} +proc _positive(x)=x>0 +proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) + ov=this_tile_x#intersect(tile_x,other_tile) + if size(ov)>0 { + _recv_slice(p,&a,ov) + } + } + } + foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) + ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) + if size(ov)>0 { + _send_slice(p,a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'false) + } +} + +proc PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) + ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) + if size(ov)>0 { + _send_slice(p,a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'false) + } +} + +proc inside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo..lo-y,hi-y..hi)) where lo=low(x),hi=high(x) +proc inside_edge(x:extent,y:tuple(int))=map($inside_edge,x,y) +proc outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y)) where lo=low(x),hi=high(x) +proc outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y) +proc _foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner) +proc _foot(d,n:extent)=n +proc PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { + PM__head_node{ + _apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'true) + } +} + +proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) + ov=this_tile_x#intersect(tile_x,other_tile) + if size(ov)>0 { + _recv_slice_sync(p,&a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),region._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'true) + } +} + +proc PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { + if shrd_nnode()>1 { + foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 { + chunk=chunk(region,envelope(nbhd._nbhd),i,b) + _bcast_slice_shared(&a,chunk) + } + } +} + +proc _rev(a:tuple)=map($_rev,a) +proc _rev(a:range)=-high(a)..-low(a) +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index,recv) { + _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,get_dim(bound,index),index,recv) + _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index-'1,recv) +} + +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index:'0,recv) { +} +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index,recv) { +} +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:CYCLE,index,recv) { + ex=get_dim(extent,index) + ev=get_dim(envelope,index) + lo=low(ex) + hi=high(ex) + up=max(high(ev),0) + down=min(low(ev),0) + upper_outside=replace(extent,index,hi+1..hi+up) + upper_inside=replace(extent,index,hi+down+1..hi) + lower_outside=replace(extent,index,lo+down..lo-1) + lower_inside=replace(extent,index,lo..lo+up-1) + _copy_bounds(&a,d,n,this_tile_x,upper_outside,lower_inside,recv) + _copy_bounds(&a,d,n,this_tile_x,lower_outside,upper_inside,recv) +} + +proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:'false) { + oldpart,oldtile=overlap(from,d._tile) + newpart,newtile=overlap(to,this_tile_x) + foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(to,overlap(from,element(d.dist,p))) + ov=overlap(this_tile_x,tile) + if size(ov)>0{ + _recv_slice(p,&a,ov) + } + } + } + foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) + ov=this_tile_x#intersect(d._tile,tile) + if size(ov)>0{ + _send_slice(p,a,ov) + } + } + } +} + +proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:'false) { + oldpart,oldtile=overlap(from,d._tile) + newpart,newtile=overlap(to,this_tile_x) + foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) + ov=this_tile_x#intersect(d._tile,tile) + if size(ov)>0{ + _send_slice(p,a,ov) + } + } + } +} + +proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:'true) { + oldpart,oldtile=overlap(from,this_tile_x) + newpart,newtile=overlap(to,this_tile_x) + o,oo=overlap(newpart,oldpart) + _set_slice(&a,element(newtile,o),a,element(oldtile,oo)) +} +proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:'true) { + oldpart,oldtile=overlap(from,this_tile_x) + newpart,newtile=overlap(to,this_tile_x) + o,oo=overlap(newpart,oldpart) + _set_slice(&a,element(newtile,o),a, element(oldtile,oo)) + foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(to,overlap(from,element(d.dist,p))) + _recv_slice(p,&a,overlap(this_tile_x,tile)) + } + } +} + +proc _send_slice(p,a:_join,o) { + _send_slice(p,a.head,o) + _send_slice(p,a.tail,o) +} +proc _recv_slice(p,&a:_join,o) { + _recv_slice(p,&a.head,o) + _recv_slice(p,&a.tail,o) +} +proc _recv_slice_sync(p,&a:_join,o){ + _recv_slice_sync(p,&a.head,o) + _recv_slice_sync(p,&a.tail,o) +} +proc _bcast_slice_shared(&a:_join,o) { + _bcast_slice_shared(&a.head,o) + _bcast_slice_shared(&a.tail,o) +} +proc _sync_messages(x:_join):_sync_messages(x.head,x.tail) +proc _not_zero(x)=if(x/=0=>1,0) +proc _crss(x)=1==map_reduce($_not_zero,$+,x) +// Add (anti) halo around tile +// Args: mshape / tile / displacement +// (mshape not used at the moment - there to cope with other topologies) +// Result: expanded tile +proc _get_halo(d:range(int),t:range(int),i:any_int)=low(t)+ii..high(t)+ii where ii=int(i) +proc _get_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)+ii..high(t)+ii by step(t) where ii=int(i) +proc _get_halo(d:range(int),t:block_seq,i:any_int){ + return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i) +} +proc _get_halo(d:range(int),t:map_seq,i:any_int) { + var a=array(0,size(t)) + for j in a,k in t.array:j=k+i + return new map_seq { + array=a + } +} +proc _get_halo(d:range(int),t:range(int),i:range(any_int))=low(t)+int(low(i))..high(t)+int(high(i)) +proc _get_halo(d:range(int),t:strided_range(int),i:range(any_int)){ + var step=step(t) + var width=size(i) + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) +} +proc _get_halo(d:range(int),t:block_seq,i:range(any_int)){ + var step=step(t) + var width=size(i)+width(t)-1 + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) +} +proc _get_halo(d:range(int),t:map_seq,i:range(any_int)) { + var a=array(0,[0..size(t)*size(i)-1]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + return _redim(a,shape(m)) +} +proc _get_halo(d:extent,j:grid,i:tuple(any_int or range(any_int)))= map($_get_halo,d,j,i) +proc _get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_halo(d.1,t.1,i) +proc _get_halo(d,t,i:null)=t +proc _get_anti_halo(d:range(int),t:range(int),i:any_int)=low(t)-ii..high(t)-ii where ii=int(i) +proc _get_anti_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)-ii..high(t)-ii by step(t) where ii=int(i) +proc _get_anti_halo(d:range(int),t:block_seq,i:any_int){ + return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i) +} +proc _get_anti_halo(d:range(int),t:map_seq,i:any_int) { + var a=array(0,size(t)) + for j in a,k in t.array:j=k-i + return new map_seq { + array=a + } +} +proc _get_anti_halo(d:range(int),t:range(int),i:range(any_int))=low(t)-int(high(i))..high(t)-int(low(i)) +proc _get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){ + var step=step(t) + var width=size(i) + if width>step { + step=1 + width=1 + } + return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width) +} +proc _get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){ + var step=step(t) + var width=size(i)+width(t)-1 + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width) +} +proc _get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) { + var a=array(0,[0..size(t)*size(i)-1]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,-high(i),-low(i)) + return _redim(a,shape(m)) +} +proc _get_anti_halo(d:extent,j:grid, i:tuple(any_int or range(any_int)))= map($_get_anti_halo,d,j,i) +proc _get_anti_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_anti_halo(d.1,t.1,i) +proc _get_anti_halo(d,t,i:null)=t +proc _interior(t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n)) +proc _interior(t:strided_range,n:range)=1..0 by 1 +proc _interior(tt:block_seq,n:range)=block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)where t=middle_blocks(tt) +proc _get_chunk(t:range,n:range,l:'true)=low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1) +proc _get_chunk(t:range,n:range,l:'false)=low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t) +proc _get_chunk(t:range,n:range,l:_down)=low(t)+w..low(t)+w+w-1 where w=max(0,-low(n)) +proc _get_chunk(t:range,n:range,l:_up)=high(t)-w-w+1..high(t)-w where w=max(0,high(n)) +proc _get_chunk(tt:block_seq,n:range,l:'true)=if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t)) where t=middle_blocks(tt) +proc _get_chunk(tt:block_seq,n:range,l:'false)=if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t)) where t=middle_blocks(tt) +proc _get_chunk(t:grid_dim,n:range,l:_left or _right)=empty(t) +proc _get_chunk(t:block_seq,n:range,l:_left)=block_seq(low(b),high(b),1,1,0) where b=first_block(t) +proc _get_chunk(t:block_seq,n:range,l:_right)=block_seq(low(b),high(b),1,1,0) where b=last_block(t) +proc _chunk(t,n,r,e,l)=if(r>e=>_interior(t,n),rt,_get_chunk(t,n,l)) +proc _get_chunk(t:tuple1d,n,e,l)=[_chunk(t.1,n.1,1,e,l)] +proc _get_chunk(t:tuple2d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l)] +proc _get_chunk(t:tuple3d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l)] +proc _get_chunk(t:tuple4d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l)] +proc _get_chunk(t:tuple5d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l)] +proc _get_chunk(t:tuple6d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l)] +proc _get_chunk(t:tuple7d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l),_chunk(t.7,n.7,7,e,l)] +proc chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1 +proc chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1 +proc chunks(t:grid,n:extent)=2 +proc _cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n +proc chunk(t:tuple(range(any_int)),n:extent,i:int) { + _cr(i,rank(t)*2) + var r=n + if i==0: r=map($_interior,t,n) elseif i&1==0: r=_get_chunk(t,n,(i+1)/2,'true) else: r=_get_chunk(t,n,(i+1)/2,'false) + return r +} + +type _left is unique +type _right is unique +type _up is unique +type _down is unique +proc chunk(t:tuple(range(any_int) or block_seq),n:extent,i:int) { + _cr(i,rank(t)*4) + var r=t + if i==0:r=map($_interior,t,n) else: switch (i-1)&3 { + case 0:r=_get_chunk(t,n,(i+3)/4,'true) + case 1:r=_get_chunk(t,n,(i+3)/4,'false) + case 2:r=_get_chunk(t,n,(i+3)/4,_left) + default:r=_get_chunk(t,n,(i+3)/4,_right) + } + return r +} +proc chunk(t:grid,n:extent,i:int) { + _cr(i,1) + var r=#t + if i==0:r=empty(#t) + return r +} +proc chunk(t:grid,n:extent,i:int,b:null)=chunk(t,n,i) +proc chunk(t:grid,n:extent,i:int,b:extent)=intersect(chunk(t,n,i),b) +proc inside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)=_get_chunk(t,n,i,low) +proc outside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)=_get_chunk(map($_exterior,t,n),n,i,low) +proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:'true)=_get_chunk(map($_exterior,t,n),n,i,_up) +proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:'false)=_get_chunk(map($_exterior,t,n),n,i,_down) +proc _exterior(t:range(int),n:range(int))=low(t)+min(low(n),0)..high(t)+max(high(n),0) +proc _get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) { + var r=t + tt=map($_exterior,t,n) + if i==0: r=#tt elseif i&1==0: r=_get_chunk(tt,n,(i+1)/2,_up) else: r=_get_chunk(tt,n,(i+1)/2,_down) + return r +} + +// ************************************************************* +// nbr% and nbhd% intrinsics +// ************************************************************* +type disp_index is any_int,tuple(any_int) +type disp_sub is disp_index,tuple(any_int or range(any_int)) +// *** Default *** +proc nbr%(x:chan,t:shared disp_index,v:shared){ + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + j=displace(region._mshape,here,t) + var y=v + if contains(region._mshape,j) { + y=x![j] + } + return y +} + +proc nbhd%(x:chan,t:shared disp_sub,v:shared) { + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + var a=array(v,#t) + foreach invar i in t { + j=displace(region._mshape,here,i) + if j in region._mshape { + a[here]=x![j] + } + } + return a +} + +// *** Blocked distributions *** +proc nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) { + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + var j=displace(region._mshape,here,t) + a,ad=tile_with_halo%(x,t,v) + return a[ad#j] +} + +proc nbhd%(region:dshape(,blocked_distr),x:chan,t:shared disp_sub,v:shared){ + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + a=displace(region._mshape,here,t) + y,yd=tile_with_halo%(x,t,v) + return y[yd#a] +} + +proc tile_with_halo%(x,t,v) { + return a,d where a,d=_local_tile_with_halo(region,PM__local(x),t,v) +} +// Return local tile with halo cells +proc _local_tile_with_halo(region,x,t,v) { + this_tile_x=_get_halo(region._mshape,region._tile,t) + var a=array(v,#this_tile_x) + foreach i in nodes_for_grid(region.dist,this_tile_x) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + var p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _recv_slice(p,&a,overlap(this_tile_x,other_tile)) + } + } + foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _send_slice(p,x,overlap(region._tile,other_tile_x)) + } + } + o,oo=overlap(this_tile_x,region._tile) + a[o]=x[oo] + _sync_messages(a,x) + return a,this_tile_x +} + +proc _local_tile_with_halo(region,x:_comp,t,v) { + this_tile_x=_get_halo(region._mshape,region._tile,t) + var a=array(v,#this_tile_x) + foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _send_slice(p,x,overlap(region._tile,other_tile_x)) + } + } + o,oo=overlap(this_tile_x,region._tile) + a[o]=x[oo] + foreach i in nodes_for_grid(region.dist,this_tile_x) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(dims(region.dist),i) and p/=_this_node() { + _recv_slice_sync(p,&a,overlap(this_tile_x,other_tile)) + } + } + _sync_messages(a,x) + return a,this_tile_x +} + +// Displace x by y within mshape d +proc displace(d:range(int),x:int,y:any_int)=x+int(y) +proc displace(d:range(int),x:int,y:range(any_int))=x+int(y._lo)..x+int(y._hi) +proc displace(d:extent1d,x:tuple1d(int),y:range(any_int) or any_int)=displace(d.1,x.1,y) +proc displace(d:extent,x:tuple(int),y:tuple(range(any_int) or any_int))=map($displace,d,x,y) +// ************************************************ +// TOPOLOGIES +// ************************************************ +proc topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l) +proc topology(tp,dis,d,l:int)=tp +PM__intrinsic<> _get_dims(int,int)->(int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int)->(int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int)->(int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int)->(int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int)->(int,int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int,int)->(int,int,int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "get_dims" +proc _zd(x,y)=if(x==1=>1,nodes_needed(y,x)) +proc cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,spread(VBLOCK,dd),n) +proc cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n) +proc cart_topo(d:tuple1d,t:tuple1d,n:int)=tuple(_get_dims(n,_zd(d.1,t.1))) +proc cart_topo(d:tuple2d,t:tuple2d,n:int)=tuple(b,a) where a,b=_get_dims(n,_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple3d,t:tuple3d,n:int)=tuple(c,b,a) where a,b,c=_get_dims(n,_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple4d,t:tuple4d,n:int)=tuple(dd,c,b,a) where a,b,c,dd=_get_dims(n,_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple5d,t:tuple5d,n:int)=tuple(e,dd,c,b,a) where a,b,c,dd,e=_get_dims(n,_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple6d,t:tuple6d,n:int)=tuple(f,e,dd,c,b,a) where a,b,c,dd,e,f=_get_dims(n,_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple7d,t:tuple7d,n:int)=tuple(g,f,e,dd,c,b,a) where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +// ************************************************ +// DISTRIBUTIONS +// ************************************************ +type distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr +type distr:iterable is null,blocked_distr,distr_dim,tuple(distr_dim),sliced_distr +type blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr) +type distr_template is null,distr_template_dim,tuple(distr_template_dim),... +type distr_template_dim is null,vblock_template,direct_template,block_template,cyclic_template,block_cyclic_template,... +// Null distribution (mirroring) +proc distribute(dis:null,d:int,t:int,p:int)=no_distr(d,t,p) +type no_distr is rec {_hi:int,_p:int,_pr:int} +proc nodes_needed(d:null,g:int)=1 +proc no_distr(g:int,d:int,p:int)=new no_distr { + _hi=int(g),_p=int(d),_pr=p +} +proc #(b:no_distr)=shape([0..b._p-1]) +proc _shp(b:no_distr)=0..b._p-1 +proc dims(b:no_distr)=[b._p] +proc size(b:no_distr)=b._p +proc element(b:no_distr,i:int)=0..b._hi-1 +proc tile_size(b:no_distr,i:int)=b._hi +proc empty(b:no_distr)=1..0 +proc nodes_for_grid(b:no_distr,g:seq(int))=b._pr..b._pr +proc node_for(b:no_distr,j:int)=b._pr +proc index(b:no_distr,j:int,p:int)=j +proc node_nhd(b:no_distr,p:int,d:range(int))=p..p +proc node_co_nhd(b:no_distr,p:int,d:range(int))=p..p +// Direct distribution (1-1 map to processor topology) +type direct_distr is rec {_p:int} +type direct_template is unique{DIRECT} +proc distribute(dis:direct_template,d:int,t:int,p:int)=direct_distr(d) +proc nodes_needed(d:direct_template,g:int)=g +proc direct_distr(d:int)=new direct_distr { + _p=int(d) +} +proc #(b:direct_distr)=shape([0..b._p-1]) +proc _shp(b:direct_distr)=0..b._p-1 +proc dims(b:direct_distr)=[b._p] +proc size(b:direct_distr)=b._p +proc element(b:direct_distr,i:int)='0..'0 +proc tile_size(b:direct_distr,i:int)='1 +proc empty(b:direct_distr)='1..'0 +proc nodes_for_grid(b:direct_distr,g:seq(int))=int(g) +proc node_for(b:direct_distr,j:int)=j +proc index(b:direct_distr,j:int,p:int)='0 +proc node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p +proc node_co_nhd(b:direct_distr,p:int,d:int or range(int))=-low(d)+p..-high(d)+p by -1 +// Variable block distribution +type vblock_distr is rec {_hi:int,_p:int} +type vblock_template is unique{VBLOCK} +proc distribute(dis:vblock_template,d:int,t:int,p:int)=vblock_distr(d,t) +proc nodes_needed(d:vblock_template,g:int)=0 +proc vblock_distr(g:int,d:int)=new vblock_distr { + _hi=int(g),_p=int(d) +} +proc #(b:vblock_distr)=shape([0..b._p-1]) +proc _shp(b:vblock_distr)=0..b._p-1 +proc dims(b:vblock_distr)=[b._p] +proc size(b:vblock_distr)=b._p +proc element(b:vblock_distr,i:int)=start..finish where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) +proc tile_size(b:vblock_distr,i:int)=finish-start+1 where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) +proc empty(b:vblock_distr)=1..0 +proc nodes_for_grid(b:vblock_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(b._p*(low(g)+1)-1,b._hi), hi1=_rdiv(b._p*(high(g)+1)-1,b._hi) +proc node_for(b:vblock_distr,j:int)=p where p=_rdiv(b._p*(j+1)-1,b._hi) +proc index(b:vblock_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._hi/b._p where jj=int(j) +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) +proc node_nhd(b:vblock_distr,p:int,d:range(int))=p+(low(d)-bk+1)/bk..p+(high(d)+bk-1)/bk where bk=b._hi/b._p +// fixed block distribution +type block_distr is rec {_b:int,_s:int,_p:int} +type _block_template is rec{block:int} +type _block_template_default is unique{BLOCK} +type block_template is _block_template_default,_block_template +proc BLOCK(block:int)=new _block_template { + block=block +} +proc distribute(dis:_block_template,d:int,t:int,p:int)=block_distr(d,t,dis.block) +proc distribute(dis:block_template,d:int,t:int,p:int)=block_distr(d,t) +proc nodes_needed(d:_block_template,g:int)=(g+d.block)/d.block +proc nodes_needed(d:block_template,g:int)=0 +proc block_distr(s:int,p:int)=new block_distr { +_b=b,_s=s,_p=p} where b=(s+p-1)/p +proc block_distr(s:int,t:int,b:int)=new block_distr { +_b=b,_s=s,_p=p} where p=(s+b-1)/b +proc #(b:block_distr)=shape([0..b._p-1]) +proc _shp(b:block_distr)=0..b._p-1 +proc dims(b:block_distr)=[b._p] +proc size(b:block_distr)=b._p +proc element(b:block_distr,i:int)=start..finish where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) +proc tile_size(b:block_distr,i:int)=finish-start+1 where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) +proc empty(b:block_distr)=1..0 +proc nodes_for_grid(b:block_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(int(low(g)),b._b), hi1=_rdiv(int(high(g)),b._b) +proc node_for(b:block_distr,j:int)=p where p=_rdiv(jj,b._b) where jj=int(j) +proc index(b:block_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._b where jj=int(j) +proc node_nhd(b:block_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b +// Cyclic distribution +type cyclic_distr is rec {_hi:int,_p:int} +type cyclic_template is unique{CYCLIC} +proc distribute(dis:cyclic_template,d:int,t:int,p:int)=cyclic_distr(d,t) +proc nodes_needed(d:cyclic_template,g:int)=0 +proc cyclic_distr(g:int,d:int)=new cyclic_distr { + _hi=int(g),_p=int(d) +} +proc #(b:cyclic_distr)=shape([0..b._p-1]) +proc _shp(b:cyclic_distr)=0..b._p-1 +proc dims(b:cyclic_distr)=[b._p] +proc size(b:cyclic_distr)=b._p +proc element(b:cyclic_distr,i:int)= int(i)..b._hi-1 by b._p +proc tile_size(b:cyclic_distr,i:int)=(b._hi-1-int(i))/b._p+1 +proc empty(b:cyclic_distr)=1..0 by 1 +proc nodes_for_grid(b:cyclic_distr,g:seq(int))=cyclic_range(lo,high,p) where high=if(hi-lo>=p=>lo+p-1,hi+if(hi>lo=>0,p)) where lo=low(g) mod p,hi=high(g) mod p where p=b._p +proc node_for(b:cyclic_distr,j:any_int)=p where p=int(j) mod b._p +proc index(b:cyclic_distr,j:int,p:int)=int(j)/b._p +proc node_nhd(b:cyclic_distr,p:int,d:range(int))=cyclic_range(p+low(d),p+high(d),b._p) +// Block cyclic distribution +type block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int} +type block_cyclic_template is rec {block:int} +proc BLOCK_CYCLIC(block:int)=new block_cyclic_template{ + block=block +} +proc distribute(dis:block_cyclic_template,d:int,t:int,p:int)=block_cyclic_distr(d,t,dis.block) +proc nodes_needed(d:block_cyclic_template,g:int)=0 +proc block_cyclic_distr(g:int,p:int,b:int)=new block_cyclic_distr { +_hi=int(g),_p=int(pp),_b=bb, _s=s} where s=pp*bb where bb=if(pp==1=>g,b) where pp=min((g+b-1)/b,p) +proc #(b:block_cyclic_distr)=shape([0..b._p-1]) +proc _shp(b:block_cyclic_distr)=0..b._p-1 +proc dims(b:block_cyclic_distr)=[b._p] +proc size(b:block_cyclic_distr)=b._p +proc element(b:block_cyclic_distr,i:int)= block_seq(s,b._hi-1,b._s,b._b,0) where s=ii*b._b where ii=int(i) +proc tile_size(b:block_cyclic_distr,i:int)=nc*b._b+max(0,min(b._b,df-nc*b._s)) where nc=df/b._s where df=b._hi-s where s=ii*b._b where ii=int(i) +proc empty(b:block_cyclic_distr)=block_seq(1,0,1,1,0) +proc nodes_for_grid(b:block_cyclic_distr,g:grid_dim)=if(hi-lo+1cyclic_range(lo,hi,p),cyclic_range(0,p-1,p)) where lo=low(g)/b._b,hi=high(g)/b._b where p=b._p +proc nodes_for_grid(b:block_cyclic_distr,g:strided_range){ + var r=0..0 + if b._s==step(g) { + r=nodes_for_grid(b,low(g)..low(g))} else { + r=nodes_for_grid(b,low(g)..high(g)) + } + return r +} + +proc nodes_for_grid(b:block_cyclic_distr,g:block_seq){ + var r=cyclic_range(0,0,1) + if b._s==step(g) { + r=nodes_for_grid(b,low(g)..low(g)+width(g)-1)} else { + r=nodes_for_grid(b,low(g)..high(g)) + } + return r +} + +proc node_for(b:block_cyclic_distr,j:int)=p where p=_rdiv(jj,b._b) mod b._p where jj=int(j) +proc index(b:block_cyclic_distr,j:int,p:int)=i where i=r+b._b*(s-p) where r=j-s*b._s where s=_rdiv(j,b._s) +proc node_nhd(b:block_cyclic_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b +proc nodes_for_grid(b,g:single_point)=nodes_for_grid(b,g._t..g._t) +// Tuple of distributions +proc distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))=map($distribute,dis,d,t,p) where p=index2point(_this_node(),t) +proc distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))=map($distribute,spread(dis,d),d,t,p) where p=index2point(_this_node(),t) +proc distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t) +proc nodes_needed(b:tuple(distr_template_dim),g:tuple(int))=map($nodes_needed,b,g) +proc nodes_needed(b:distr_template_dim,g:tuple(int))=map($nodes_needed,spread(b,g),g) +proc node_for(b:tuple(distr_dim),j:tuple(int))=map($node_for,b,j) +proc #(b:tuple(distr_dim))=shape(map($_shp,b)) +proc dims(b:tuple(distr_dim))=map($size,b) +proc element(b:tuple(distr_dim),i:tuple(int))=map($element,b,i) +proc element(b:tuple(distr_dim),i:int)=element(b,index2point(i,dims(b))) +proc tile_size(b:tuple(distr_dim),i:tuple(int))=map($tile_size,b,i) +proc empty(b:tuple(distr_dim))=map($empty,b) +proc nodes_for_grid(b:tuple(distr_dim),g:grid_slice)=map($nodes_for_grid,b,g) +proc node_num_for(b:tuple(distr_dim),j:tuple(int))=index(dims(b),map($node_for,b,j)) +proc index(b:tuple(distr_dim),j:tuple(int),p:tuple(int))=index(tile_size(b,p),map($index,b,j,p)) +proc node_and_index(b:tuple(distr_dim),j:tuple(int))=index(dims(b),p),i where i=index(tile_size(b,p),map($index,b,j,p)) where p=map($node_for,b,j) +proc node_and_index(b:distr_dim,j:int)=p,i where i=index(b,j,p) where p=node_for(b,j) +proc node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d) +proc node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d) +// Slice of a tuple of distributions +type sliced_distr(t,s) is rec{_t:t,_s:s} +proc sliced_distr(t:tuple(distr_dim),s:tuple(seq(int) or single_point(int)))=new sliced_distr{ + _t=t,_s=s +} +proc node_for(t:sliced_distr,j:tuple(int))=node_for(t._t,t._s[j]) +proc #(t:sliced_distr)=#t._t +proc dims(t:sliced_distr)=dims(t._t) +proc element(t:sliced_distr,i:tuple(int) or int)=overlap(t._s,element(t._t,i)) +proc tile_size(t:sliced_distr,i:tuple(int) or int)=dims(element(t,i)) +proc empty(t:sliced_distr)=new sliced_distr{ + _t=empty(t._t),_s=t._s +} +proc nodes_for_grid(t:sliced_distr,g:grid)=nodes_for_grid(t._t,t._s[g]) +proc node_num_for(t:sliced_distr,j:tuple(int))=node_num_for(t._t,t._s[j]) +proc index(t:sliced_distr,j:tuple(int),p:tuple(int))=index(tile_size(t,p),element(t,p)#j) +proc node_and_index(t:sliced_distr,j:int)=p,i where i=index(t,j,p) where p=node_for(t,j) +proc node_nhd(t:sliced_distr,p:tuple,d:tuple)=node_nhd(t._t,p,_stpmult(d,t._s)) +proc node_co_nhd(t:sliced_distr,p:tuple,d:tuple)=node_co_nhd(t._t,p,_stpmult(d,t._s)) +proc _stpmult(d:tuple,s:tuple)=map($_stpmult,d,s) +proc _stpmult(d:range,s:range)=d +proc _stpmult(d:range,s:strided_range)=if(st>0=>st*low(d)..st*high(d),st*high(d)..st*low(d)) where st=step(s) +// ***************************************** +// SUPPORT FOR PARALLEL STATEMENTS +// ***************************************** +// Get and set elements in "for" +proc PM__getelem(x:grid_slice_dim or cyclic_range,y)=element(x,y) +proc PM__getelem(x:grid_slice or iterable_grid,y)=element(x,y) +proc PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t)) +proc PM__getelem(a:array_slice(any^any,),y)=element(a,y) +proc PM__getelem(x:array_template,y)=x._a +proc PM__getelem(a:any^dshape,t)=element(a,(#a)[t]) +proc PM__setelem(&x,v,y) { + _set_elem(&x,v,(#x)[y]) +} +proc PM__setelem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(dims(a),t),v) +} + +proc PM__setelem(&a:any^dshape,v,t:index) { + PM__setaelem(&a,i,v) check p==_this_node() where p,i=node_and_index((#a).dist,_tup(t)) +} + +proc PM__setelem(&a:array_slice(any^any,),v,t:index) { + _set_elem(&a._a,v,a._s[t]) +} + +proc PM__get_elem%(x,i,h)=PM__getelem(x,h) +proc PM__set_elem%(&x:invar,v:complete,i,h){ + PM__setelem(&x,v,h <>) + _assemble%(&x,region) +} +proc PM__get_elem%(x:shared any^dshape,i,h)=element(PM__local(x),i) +proc PM__set_elem%(&x:invar any^dshape,v:complete,i,h) { + _set_elem(&^(PM__local(^(&x))),v,i <>) +} +proc PM__get_elem%(x:shared array_slice(any^dshape),j,h)=_get_aelem(x._a,i) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +proc PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){ + PM__setaelem(&x._a,i,v <>) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +} + +proc _assemble%(&a:invar any^mshape,xregion:invar mshape) { +} +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) { +} +proc _assemble%(&a:invar any^mshape,xregion:invar) shared <> { + dist=xregion.dist + foreach p in #(dist) { + tile=dist[p] + i=index(dims(dist),p) + if i==_this_node() { + forall j in tile { + var k=PM__getelem(a,j) + PM__broadcast(&k,i) + } + } else { + forall j in tile { + var k=_arb(a) + PM__broadcast(&k,i) + PM__setelem(&a,k,j <>) + } + } + } +} + +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> { + dist=xregion.dist + foreach p in #(dist) { + tile=intersect((#(a._a))#a._s,dist[p]) + i=index(dims(dist),p) + if i==_this_node() { + forall j in tile { + var k=PM__getelem(a._a,j) + PM__broadcast(&k,i) + } + } else { + forall j in tile { + var k=_arb(a._a) + PM__broadcast(&k,i) + PM__setelem(&a._a,k,j <>) + } + } + } +} + +// Support for % procs +proc PM__get_tilesz(d)=d._tile,d._size +proc PM__get_tilesz(d:mshape)=d,size(d) +// Support for ! operator +PM__if_compiling +proc PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region)) +proc PM__makearray%(x:priv)=_makearray(x,region,size(region)):test "Can only apply ""!"" to a ""chan"" " => 'false +proc PM__makearray%(x:invar)=_makearray(x,region,size(region)):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => 'false +PM__intrinsic<> _makearray(x:any,y:any,z:any)->(PM__invar_dim x,y) : "make_array" +PM__else +proc PM__makearray%(x:chan) complete <>=_makearray(x,region) +proc PM__makearray%(x:priv)=_makearray(x,region):test "Can only apply ""!"" to a ""chan"" " => 'false +proc PM__makearray%(x:invar)=_makearray(x,region):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => 'false +PM__intrinsic<> _makearray(x:any,y:any)->(PM__dim x,y) : "make_array" +PM__endif +// active%() intrinsic +proc active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>) +proc _masked%(x) complete <>=masked(x) +proc active%()=^(^??,coherent) +PM__intrinsic PM__active()->(bool) : "active" +// Imports and exports +PM__intrinsic _import_val(x:any)->(=x) : "import_val" +PM__intrinsic PM__importshrd(x:any)->(=x) : "import_val" +PM__intrinsic<> PM__importvarg(x:any)->(=x) : "import_varg" +PM__intrinsic _import_scalar(x:any)->(invar x) : "import_scalar" +proc PM__import_val(x) { + PM__checkimp(x) + return _import_val(x) +} +proc PM__impscalar(x) { + PM__checkimp(x) + return _import_scalar(x) +} +proc PM__import_val(x:^*(,,,,)) { + test "Compiler internal error:importing reference" => 'false + return x +} +proc PM__impscalar(x:^*(,,,,)) { + test "Compiler internal error:importing reference" => 'false + return x +} +proc PM__checkimp(x,arg...) { + PM__checkimp(x) + PM__checkimp(arg...) +} +proc PM__checkimp(x) { +} +proc PM__checkimp(x:contains(PM__distr_tag)) { + test "Cannot import a distributed value into a nested parallel scope" => 'false +} +type schedule(subregion,blocking) is rec{_subregion:subregion,_subtile,_blocking:blocking} +proc subregion(schedule:schedule)=schedule._subregion +proc subregion(schedule:null)=null +proc subtile(schedule:schedule)=schedule._subtile +// Over statements +proc PM__over%(schedule:null,x:invar,block:invar) shared <>=new schedule{ + _subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region) +} +proc PM__over%(x:invar,block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(x,schedule._subregion) +proc PM__make_over%(schedule:null,x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s where s=fill_in(region._extent,x,null) +proc PM__make_over%(x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(map($norm,fill_in(region._extent,x,'true)),schedule._subregion) +proc PM__make_over%(x:invar,block)=x check "Expression in an ""over"" statement must be a subscript tuple"=>'false +proc PM__make_over%(x,block)=x check "Expression in an ""over"" statement must be ""invar"""=>'false +proc _blocking(b:tuple(any_int),region)=int(b) { + test "Blocking factor must have same rank as current region"=> rank(b)==rank(extent(region)) +} + +proc _blocking(b,region)=null { + test "Blocking factor must be a tuple of integers"=>'false +} +proc _blocking(b:null,region)=null +PM__if_compiling +proc PM__do_over(x:null,region)=x +proc PM__do_over(x:schedule,region)=_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking) +proc _do_elem(x:range(int))=_st(low(x),high(x)) +proc _do_elem(x:strided_range(int))=_st(low(x),high(x),step(x)) +proc _do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x)) +proc _do_elem(x:map_seq)=_st(x.array,size(x.array),null,null) +proc _do_elem(x:single_point)=_st(x._t) +proc PM__nested_loop(x:null){ +} +PM__intrinsic PM__nested_loop(any): "nested_loop" +proc _ldims(x:mshape)=map_apply($size,$_st,x._extent) +proc _ldims(x:dshape)=map_apply($size,$_st,x._tile) +PM__else +proc PM__do_over%(x:null)=true +proc PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion +proc PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile) +proc PM__do_over%(x:invar grid) complete <>{ + chan var t=false + _in%(x,&^(PM__local(^(&t!))) <>) + return t +} + +proc PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x +proc _in%(x:invar,&t:invar) shared <>{ + forall i in x { + sync t[i]=true + } +} +PM__endif +// Parallel processing inquiry +PM__intrinsic _sys_node()->(int) : "sys_node" +PM__intrinsic sys_nnode()->(int) : "sys_nnode" +PM__intrinsic _this_node()->(int) : "this_node"(1) +PM__intrinsic this_node%(r:any,s:any,h:any)->(int) : "this_node"(2) +PM__intrinsic this_nnode()->(int) : "this_nnode" +PM__intrinsic _shrd_node()->(int) : "shared_node" +PM__intrinsic shrd_nnode()->(int) : "shared_nnode" +PM__intrinsic _root_node()->(int) : "root_node" +PM__intrinsic is_shrd()->(bool) : "is_shared" +PM__intrinsic is_shrd(any)->(bool) : "is_shared" +PM__intrinsic is_par()->(bool) : "is_par" +proc _head_node()=_shrd_node()==0 +// Parallel system nested contexts +PM__intrinsic<> _push_node_grid(arg...:any): "push_node_grid" +proc _push_node(d:int,t:int){ + _push_node_grid(false,t) +} +proc _push_node(d:tuple1d,t:tuple1d,e:tuple1d) { + _push_node_grid(is_cyclic(e.1),t.1) +} + +proc _push_node(d:tuple2d,t:tuple2d,e:tuple2d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),t.1,t.2) +} + +proc _push_node(d:tuple3d,t:tuple3d,e:tuple3d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),t.1,t.2,t.3) +} + +proc _push_node(d:tuple4d,t:tuple4d,e:tuple4d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),t.1,t.2,t.3,t.4) +} + +proc _push_node(d:tuple5d,t:tuple5d,e:tuple5d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),t.1,t.2,t.3,t.4,t.5) +} + +proc _push_node(d:tuple6d,t:tuple6d,e:tuple6d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),t.1,t.2,t.3,t.4,t.5,t.6) +} + +proc _push_node(d:tuple7d,t:tuple7d,e:tuple7) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),t.1,t.2,t.3,t.4,t.5,t.6,t.7) +} + +PM__intrinsic<> _push_node_split(int): "push_node_split" +PM__intrinsic _push_node_conc(): "push_node_conc" +proc PM__pop_node(x:mshape) { +} +PM__intrinsic PM__pop_node(x:shape): "pop_node" +PM__intrinsic PM__pop_conc(bool): "pop_node_conc" +PM__intrinsic<> _push_node_dist(): "push_node_distr" +proc _lvl()=1 +// ************************************************ +// PROCESSOR ALLOCATION +// ************************************************ +proc PM__partition(pp,d:dshape) { + _push_node_dist() + return dd._tile,dd,null where dd=new dshape { + _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} +proc PM__partition(pp,d:dshape,distr:null,topo:null,simplify:null,work:null,sched,block) { + _push_node_dist() + return dd._tile,dd,_block_schedule(block,dd) where dd=new dshape { + _mshape=#d._mshape,dist=d.dist, _tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} + +proc PM__partition(pp,d:dshape,distr,topo,simplify,work,sched,block) { + test "Cannot have attributes in ""for""statement over distributed value" => 'false + return dd._tile,dd,null where dd=new dshape { + _mshape=##d,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} +proc PM__partition(pp,d:mshape)=tile,shape,sched where tile,shape,sched= PM__partition(pp,d,null,null,null,null,null,null) +proc PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) { + d=dims(mshape) + topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode())) + var p=_shrd_node() + dist=distribute(distr,d,topol) + s=size(#(dist)) + np=shrd_nnode() + test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np + if s=s { + p=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) + } + _push_node_split(p) } else { + _push_node_dist() + } + elem=element(dist,p) + elemsz=#elem + dd=new dshape { + _mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz, _size=size(elemsz),_level=_lvl() + } + return dd._tile,dd,_block_schedule(block,dd) +} + +proc PM__partition(pp:null,d:mshape,distr,topo,simplify,work,sched,block)=#d._extent,#d,_block_schedule(block,#d) +proc PM__partition(pp:null,d:dshape,distr,topo,simplify,work,sched,block)=#d._extent,#d._mshape,_block_schedule(block,#d._mshape) +proc _block_schedule(block:null,region)=null +proc _block_schedule(block,region)=new schedule{ + _subregion=region,_subtile=region._tile,_blocking=_blocking(block,region) +} +proc workshare(work:null,d,dist,nnode:int,snode:int,nsnode:int)=nnode*(2*snode+1)/(2*nsnode) +proc workshare(work:array(int),d,dist,nnode:int,snode:int,nsnode:int) { + test "work array does not conform to mshape"=>conform(#work,#d) + var wk=work + return _wshare(wk,nnode,snode,nsnode) +} + +PM__intrinsic _wshare(int^any,int,int,int)->(int) : "wshare" +// ************************************************************* +// I/O OPERATIONS +// ************************************************************* +// Built-in operators +PM__intrinsic<> _open_file(string,bool,bool,bool,bool,bool,bool,bool)->(sint,sint) : "open_file" +PM__intrinsic<> _close_file(sint)->(sint) : "close_file" +PM__intrinsic<> _seek_file(sint,lint)->(sint) : "seek_file" +PM__intrinsic<> _read_file(sint,&any)->(sint) : "read_file" +PM__intrinsic<> _write_file(sint,any)->(sint) : "write_file" +PM__intrinsic<> _read_file_array(sint,&any,int)->(sint) : "read_file_array" +PM__intrinsic<> _write_file_array(sint,any,int)->(sint) : "write_file_array" +PM__intrinsic<> _read_file_tile%(any,any,any,sint,&any,int,int)->(sint) : "read_file_tile" +PM__intrinsic<> _write_file_tile%(any,any,any,sint,any,int,int)->(sint) : "write_file_tile" +PM__intrinsic<> _io_error_string(sint)->(string) : "io_error_string" +// IO/related types +type io_type is num,bool +type filesystem is rec{_tag:PM__distr_tag} +type file is struct {_f:sint,_tag:PM__distr_tag} +type io_error is rec {_errno:sint,use _iserr:bool} +proc PM__filesys()=new filesystem{ +} +// Basic operations + +// @@ with no keys... now, need to pass through keywords + +proc open(&filesystem:filesystem,name,append=false,create=false,temp=false,excl=false,read=false,write=false,seq=false)=new file { + _f=f +},_make_file_error(err) where f,err=_open_file(name,append,create,temp,excl,read,write,seq) +proc _make_file_error(x:sint)=new io_error { + _errno=x,_iserr=x/=0 +} +proc close(&f:file){ + err=_close_file(f._f) + return _make_file_error(err) +} +proc seek(&f:file,j:lint){ + err=_seek_file(f._f,j) + return _make_file_error(err) +} +proc read(&f:file,&x:io_type){ + err=_read_file(f._f,&x) + return _make_file_error(err) +} +proc write(&f:file,x:io_type){ + err=_write_file(f._f,x) + return _make_file_error(err) +} +// Array I/O +proc read(&f:file,&x:io_type^mshape){ + err=_read_file_array(f._f,&x,size(x)) + return _make_file_error(err) +} +proc write(&f:file,x:io_type^mshape){ + err=_write_file_array(f._f,x,size(x)) + return _make_file_error(err) +} +proc read(&f:file,&x:io_type^dshape) { + var err=_make_file_error(0's) + for i in x:err=read%(&f,&i) + return err +} +proc write(&f:file,x:io_type^dshape) { + var err=_make_file_error(0's) + for i in x:err=write%(&f,i) +} +// Distributed I/O +proc partition%(f:filesystem)=f:test "Partition not yet implemented"=>'false +proc read%(&f:shared file,&x:complete io_type){ + err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape)) + return _make_file_error(err) +} +proc write%(&f:shared file,x:complete io_type){ + err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape)) + return _make_file_error(err) +} +// Error trapping versions of I/O routines +proc string(error:io_error)=_io_error_string(error._errno) +proc open(&f:filesystem,name:string) { + file,error=open(&f,name) + test "Error opening file """++name++""": "++error=>not(error) + return file +} + +proc close(&f:file) { + error=close(&f) + test "Error closing file:"++error=>not(error) +} +proc read(&f:file,&x) { + error=read(&f,&x) + test "Error reading from file:"++error=>not(error) +} +proc write(&f:file,x) { + error=write(&f,x) + test "Error writing to file:"++error=>not(error) +} +proc seek(&f:file,x:lint) { + error=seek(&f,x) + test "Error on seek:"++error=>not(error) +} +proc read%(&f:shared file,&x) { + error=read%(&f,&x) + test "Error reading from file:"++error=>not(error) +} +proc write%(&f:shared file,x) { + error=write%(&f,x) + test "Error writing to file:"=>not(error) +} +// ************************************************************* +// SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS +// ************************************************************* +// SOA tuples +type _stuple1d is rec^{t1} +type _stuple2d is rec^{t1,t2} +type _stuple3d is rec^{t1,t2,t3} +type _stuple4d is rec^{t1,t2,t3,t4} +type _stuple5d is rec^{t1,t2,t3,t4,t5} +type _stuple6d is rec^{t1,t2,t3,t4,t5,t6} +type _stuple7d is rec^{t1,t2,t3,t4,t5,t6,t7} +proc _st(t1)=new _stuple1d{ + t1=t1 +} +proc _st(t1,t2)=new _stuple2d{ + t1=t1,t2=t2 +} +proc _st(t1,t2,t3)=new _stuple3d{ + t1=t1,t2=t2,t3=t3 +} +proc _st(t1,t2,t3,t4)=new _stuple4d{ + t1=t1,t2=t2,t3=t3,t4=t4 +} +proc _st(t1,t2,t3,t4,t5)=new _stuple5d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5 +} +proc _st(t1,t2,t3,t4,t5,t6)=new _stuple6d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 +} +proc _st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7 +} +// Create normalised form of a grid used for _xxx_slice operations +proc _norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x)) +proc _norm(n,x:map_seq)=_st(x.array,n) +proc _norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x)) +// Apply idxdim index and convert to normal for for _send_slice_mapped +proc _dnorm(x:indexed_dim('1),m,n:single_point)=_st(m,t,t,1,1,0) where t=_dmap(x,n._t) +proc _dnorm(x:indexed_dim('1),m,n:range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),1,1,0) +proc _dnorm(x:indexed_dim('1),m,n:strided_range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),x._st*n._m,1,0) +proc _dnorm(x:indexed_dim('1,'1),m,n:block_seq)=_st(m,n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) +proc _dnorm(x:indexed_dim('1),m,n:block_seq)=_dnorm(x,m,map_seq(n)) +proc _dnorm(x:indexed_dim('1),m,n:map_seq){ + var a=array(0,#n._array) + forall i in a,j in n._array:i=_dmap(x,j) + return _st(a) +} +proc _dnorm(x:indexed_dim('1),m,n:grid)=_st(map_apply($_dnorm,$_st,x,m,n),size(n)) +type _griddef is rec^{grid,elems} +proc _gd(grid,elems,size)=new _griddef{ + grid=grid,elems=elems +} +proc _send_slice(p,x:_comp^any,d) { + forall i in d { + _isend_offset%(j,p,x) where j=index(#x,i) + } +} + +proc _send_slice(p,x,d) { + _isend_offset(_norm(dims(x),d),p,x) +} + +proc _send_slice_mapped(p,x,d,t,s) { + forall k in d { + _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) + } +} + +proc _send_slice_mapped(p,x:_comp^any,d,t:indexed_dim('1),s) { + forall k in d { + _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) + } +} + +proc _send_slice_mapped(p,x,d,t:indexed_dim('1),s) { + _isend_offset(_dnorm(t,dims(x),d),p,x) +} + +proc _recv_slice(p,&x:_comp^any,d) { + forall i in d { + _irecv_offset%(j,p,&x) where j=index(#x,i) + } +} + +proc _recv_slice(p,&x,d) { + _irecv_offset(_norm(dims(x),d),p,&x) +} + +proc _recv_slice_sync(p,&x:_comp^any,d) { + forall i in d { + _recv_offset%(j,p,&x) where j=index(#x,i) + } +} + +proc _recv_slice_sync(p,&x,d) { + _recv_offset(_norm(dims(x),d),p,&x) +} + +proc _bcast_slice_shared(&x,d){ + _bcast_shared_offset(_norm(dims(x),d),&x) +} +proc _send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^('true)) { + forall i in d { + j=index(sx,i) + _isend_recv_req%(j,p,^(x),&^(^(a))) + } +} + +proc _send_recv_slice_req(p,x,&a,sx,d,c:^^('true)) { + _isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a))) +} +proc _send_recv_slice_req(p,x,&a,sx,d,c) { + forall i in d { + j=index(sx,i) + _isend_recv_req%(j,p,^(x),&^(^(a)),c) + } +} + +proc _send_slice_assn(p,x:_comp,y,sx,d,c:^^('true)) { + forall i in d { + _isend_assn%(j,^(p),^(x),^(y)) where j=index(sx,i) + } +} + +proc _send_slice_assn(p,x,y,sx,d,c:^^('true)) { + _isend_assn(_norm(dims(sx),d),p,x,y) +} +proc _send_slice_assn(p,x,y,sx,d,c) { + forall i in d { + _isend_assn%(j,p,^(x),^(y),^(c)) where j=index(sx,i) + } +} + +proc _recv_slice_reply(p,&x:_comp,sx,d,c:^^('true)) { + forall i in d { + _recv_reply%(j,^(p),&^(^(x))) where j=index(sx,i) + } +} + +proc _recv_slice_reply(p,&x,sx,d,c:^^('true)) { + _recv_reply(_norm(dims(sx),d),p,&x) +} +proc _recv_slice_reply(p,&x,sx,d,c) { + forall i in d { + _recv_reply%(j,p,&^(^(x)),c) where j=index(sx,i) + } +} + +PM__intrinsic<> _isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any): "isend_offset" +PM__intrinsic<> _isend_offset(j:any,p:any,x:any): "isend_grid" +PM__intrinsic<> _irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "irecv_offset" +PM__intrinsic<> _irecv_offset(j:any,p:any,&x:any): "irecv_grid" +PM__intrinsic<> _recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_offset" +PM__intrinsic<> _recv_offset(j:any,p:any,&x:any): "recv_grid" +PM__intrinsic<> _bcast_shared_offset%(r:any,s:any,h:any,j:any,&x:any): "bcast_shared_offset" +PM__intrinsic<> _bcast_shared_offset(j:any,&x:any): "bcast_shared_grid" +PM__intrinsic<> _isend(p:any,x:any): "isend" +PM__intrinsic<> _irecv(p:any,&x:any): "irecv" +PM__intrinsic<> _recv(p:any,&x:any): "recv" +PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any): "isend_req" +PM__intrinsic<> _isend_recv_req(j:any,p:any,x:any,&a:any): "isend_req" +PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any): "isend_req" +PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any): "isend_assn" +PM__intrinsic<> _isend_assn(j:any,p:any,x:any,y:any): "isend_assn" +PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any): "isend_assn" +PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any): "recv_reply" +PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_reply" +PM__intrinsic<> _recv_reply(j:any,p:any,&x:any): "recv_reply" +PM__intrinsic<> _bcast_shared(&x:any): "broadcast_shared" +PM__intrinsic<> _bcast_shared(&x:any,p:int): "broadcast_shared" +type _ct is array_slice,^*(,,,,),any^any,^^(any) +proc PM__sync_messages(x)<>:_sync_messages(x) +PM__if_compiling +proc _sync_messages(x:_ct):_do_sync_messages(_core(x)) +proc _sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y)) +proc _core(x:any^any)=x +proc _core(x:^^(any))=x +proc _core(x:array_slice)=_core(x._a) +proc _core(x:^*(,,,,))=_core(_v2(x)) +PM__intrinsic<> _do_sync_messages(arg...:^^(any) or any^any): "sync_mess" +PM__else +PM__intrinsic<> _sync_messages(arg...:_ct): "sync_mess" +PM__endif +proc _tup(x:tuple)=x +proc _tup(arg...)=tuple(arg...) +proc _tup(x:null)=x +proc _tup%(x:invar) shared=_tup(x) +PM__intrinsic<> PM__broadcast(&b:any,a:int): "broadcast" +PM__intrinsic<> PM__broadcast(b:any,a:int)->(=b) : "broadcast_val" +PM__intrinsic<> get_remote%(r:any,s:any,h:any,a:shared any^dshape,b:int,c:int)->(%a) : "get_remote_distr" +PM__intrinsic<> put_remote%(r:any,s:any,h:any,a:shared any^dshape,b:any,c:int,d:int): "put_remote_distr" +// ******************************************************** +// OTHER COMMUNICATING & ARRAY OPERATIONS +// ******************************************************** +proc map(p:proc,x:any^any) { + var z=array(p.(_arb(x)),#x) + for i in z, j in x:i=p.(j) +} +proc map(p:proc,x:any^any,y:any^any) { + var z=array(p.(_arb(x),_arb(y)),#x) + for i in z,j in x,k in y:i=p.(j,k) +} +proc map(p:proc,x:any^mshape,y:any^dshape) { + var z=array(p.(_arb(x),_arb(y)),#(y)) + for i in z,j in x,k in y:i=p.(j,k) +} +proc map_const(p:proc,x:any^mshape,y:any){ + var z=array(p.(_arb(x),y),#x) + for i in z,j in x:i=p.(j,y) +} +proc +(x:num^any,y:num^any)=map($+,x,y) +proc -(x:num^any,y:num^any)=map($-,x,y) +proc *(x:num^any,y:num^any)=map($*,x,y) +proc /(x:num^any,y:num^any)=map($/,x,y) +proc **(x:num^any,y:num^any)=map($**,x,y) +proc mod(x:real_num^any,y:real_num^any)=map($mod,x,y) +proc max(x:real_num^any,y:real_num^any)=map($max,x,y) +proc min(x:real_num^any,y:real_num^any)=map($min,x,y) +proc +(x:num^any,y:any)=map_const($+,x,y) +proc -(x:num^any,y:any)=map_const($-,x,y) +proc *(x:num^any,y:any)=map_const($*,x,y) +proc /(x:num^any,y:any)=map_const($/,x,y) +proc **(x:num^any,y:any)=map_const($**,x,y) +proc mod(x:real_num^any,y:real_num)=map_const($mod,x,y) +proc max(x:real_num^any,y:real_num)=map_const($max,x,y) +proc min(x:real_num^any,y:real_num)=map_const($min,x,y) +PM__intrinsic _pack(v:any,any,any,d:any)->(PM__dim v,d) : "pack" +proc pack(v:any^mshape,m:bool^mshape) { + test "arrays do not conform"=>conform(#v,#m) + result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) +} + +proc pack(vv:array,mm:array) { + var v=vv + var m=mm + return _pack(v,m,n,tuple(0..n-1)) where n=count(m) +} + +// Reduction +type associative_proc is $+,$*,$max,$min,$&,$|,$xor,$++,$==,... +PM__if_compiling +proc reduce(p:proc,x:array(,mshape)) { + var s=_get_aelem(x,0) + foreach i in 1..size(#x)-1 { + s=p.(s,_get_aelem(x,i)) + } + return s +} +PM__else +proc reduce(p:proc,x:array(,mshape)) { + var y=x + var n=size(x) + while n>1 { + var m=(n+1)/2 + forall k in m..n-1 { + PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>) + } + n=m + } + return _get_aelem(y,0) +} + +PM__endif +proc reduce(p:proc,y:array)=_reduce(p,reduce(p,PM__local(y))) +proc _reduce_for_assign%(p:invar associative_proc,y,init:invar){ + chan yy=y + return reduce%(p,yy,init) +} +proc _reduce_for_assign%(p:invar $-,y,init:invar){ + chan yy=y + return init - _reduce%($+,yy,init) +} +proc _reduce_for_assign%(p:invar $/,y,init:invar){ + chan yy=y + return init / _reduce%($*,yy,init) +} +proc reduce%(p:invar proc,y:chan,init)=^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform) +proc _reduce%(p:invar proc,y:chan)=^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform) +proc _reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y) +proc __reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y) +proc _reduce(p:proc,y) { + var x=array(y,[0..0]) + var z=array(y,[0..0]) + var n=this_nnode() + var i=1 + until i>n-1 { + other=_this_node() xor i + if other=y._lo and x<=y._hi +proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:int_literal,y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x +type _crange is rec{_lo,_hi} +proc PM__caserange(x,y)=x..y +proc PM__caserange(x:fix(int),y:fix(int))=new _crange{ + _lo=x,_hi=y +} + +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:'true,y,z)=y +proc PM__if(x:'false,y,z)=z +proc PM__if(x:'true,y:literal,z)=y +proc PM__if(x:'false,y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...)) + +// Assignment +proc PM__assign_or_init(a,b)<>=a { + PM__assign_var(&^(a),b) +} + +proc PM__assign_or_init(a:,b)=PM__dup(b as a) + +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} + +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a +} + +type assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,... + +proc PM__assign(&a:any,b:any,c:assignment_operator) { + PM__assign(&a,c.(a,b)) +} + +proc PM__assign(&a:any,b:any,c:proc) { + test "Not a recognised assignment operator"=>'false +} + +proc check_assign_types(x,y){ + test "Type mismatch in assignment"=>same_type(x,y) +} +proc _assign(&a,b) { + _assign_element(&a,b) +} +proc _assign(&a:contains(farray),b) { + _assign_structure(&a,b) +} +proc _assign_structure(&a,b)<>{ + _assign_element(&a,b) +} +proc _assign_structure(&a:farray,b){ + _array_assign(&a,b,'true) +} +PM__intrinsic _assign_element(&any,any): "assign" + + +// Other variable operations +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +proc PM__dup(PM__dup) <>=PM__clone(PM__dup) +PM__intrinsic PM__dup(x:fix int)->(int) : "clone" +PM__intrinsic PM__dup(x:fix real)->(real) : "clone" +PM__intrinsic PM__dup(x:fix string)->(string) : "clone" +PM__intrinsic PM__dup(x:fix bool)->(bool) : "clone" +PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" +PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" +proc ==(x:any,y:any) { + test "Cannot apply ""=="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return not ok +} +proc _eq(x:any,y:any,&ok) <> { + ok=ok and x==y +} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) + +PM__intrinsic<> PM__element_at(x:any,y:int_literal)->(|x):"elem" + +proc elements(x)=_elements(x,1) +proc _elements(x,i:int_literal) { + const e + if '(i==num_elements(x)) { + e=_cons(PM__element_at(x,i),_list_end) + } else { + e=_cons(PM__element_at(x,i),_elements(x,i+1)) + } + return e +} + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnt(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=PM__cast(x,typeof(t)) +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic<> error_type()->(?0) : "call" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump(x)<>:_dump("Value:",x) +proc PM__dump(y,x)<>:if y:_dump("Value:",x) +proc PM__dump%(x)<>{ + print("$"++here) + _dump(string(here),x) +} +proc PM__dump%(y:bool,x)<>{ + if y:_dump(string(here),x) +} +proc PM__dump%(y,x){ + test "Selection expression in '$$dump' not 'bool'" => 'false + $$infer_type(y) +} +PM__intrinsic<> old_dump(any): "dump" +proc old_dumpit(a) { + old_dump(a) + return a +} + +PM__intrinsic<> old_dump_id(any): "dump_id" + +proc PM__filesys()=1 diff --git a/src/array.f90 b/src/array.f90 index 587b7bb..0942268 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -3969,20 +3969,27 @@ recursive subroutine vector_dump(context,v,depth) integer,intent(in):: depth character(len=80):: spaces=' ' integer:: k - type(pm_ptr):: name + type(pm_ptr):: name,p integer:: tno,i if(depth>=35) then write(*,*) spaces(1:depth*2),'...' endif k=pm_fast_typeof(v) - !write(*,*) 'k=',k + write(*,*) 'k=',k select case(k) case(pm_array_type,pm_const_array_type) - write(*,*) spaces(1:depth*2),'Array (',v%data%hash,v%offset - call vector_dump(context,v%data%ptr(v%offset+pm_array_vect),depth+1) - write(*,*) spaces(1:depth*2),') over (' - call vector_dump(context,v%data%ptr(v%offset+pm_array_dom),depth+1) - write(*,*) spaces(1:depth*2),')' + p=v%data%ptr(v%offset+pm_array_vect) + p=p%data%ptr(p%offset) + write(*,*) 'vkind=',pm_fast_vkind(p) + if(pm_fast_vkind(p)==pm_string) then + write(*,*) spaces(1:depth*2),trim(pm_value_as_string(context,p)) + else + write(*,*) spaces(1:depth*2),'Array (',v%data%hash,v%offset + call vector_dump(context,v%data%ptr(v%offset+pm_array_vect),depth+1) + write(*,*) spaces(1:depth*2),') over (' + call vector_dump(context,v%data%ptr(v%offset+pm_array_dom),depth+1) + write(*,*) spaces(1:depth*2),')' + endif case(pm_dref_type,pm_dref_shared_type) if(k==pm_dref_type) then write(*,*) spaces(1:depth*2),'D-ref (' @@ -4027,7 +4034,7 @@ recursive subroutine vector_dump(context,v,depth) contains include 'ftypeof.inc' include 'fesize.inc' - + include 'fvkind.inc' end subroutine vector_dump recursive subroutine vector_dump_to(context,v,j,output,depth) @@ -4054,17 +4061,21 @@ end subroutine output k=pm_fast_typeof(v) select case(k) case(pm_array_type,pm_const_array_type) - call output(context,spaces(1:depth*2)//'Array (') w=v%data%ptr(v%offset+pm_array_vect) w=w%data%ptr(w%offset+j) - esize=vector_esize(w) - do jj=0,min(5,esize) - call vector_dump_to(context,w,jj,output,depth+1) - enddo - if(esize>5) call output(context,spaces(1:depth*2+2)//'...') - call output(context,spaces(1:depth*2)//') over (') - call vector_dump_to(context,v%data%ptr(v%offset+pm_array_dom),j,output,depth+1) - call output(context,spaces(1:depth*2)//')') + if(pm_fast_vkind(w)==pm_string) then + call output(context,spaces(1:depth*2)//trim(pm_value_as_string(context,w))) + else + call output(context,spaces(1:depth*2)//'Array (') + esize=vector_esize(w) + do jj=0,min(5,esize) + call vector_dump_to(context,w,jj,output,depth+1) + enddo + if(esize>5) call output(context,spaces(1:depth*2+2)//'...') + call output(context,spaces(1:depth*2)//') over (') + call vector_dump_to(context,v%data%ptr(v%offset+pm_array_dom),j,output,depth+1) + call output(context,spaces(1:depth*2)//')') + endif case(pm_dref_type,pm_dref_shared_type) if(k==pm_dref_type) then call output(context,spaces(1:depth*2)//'D-ref (') @@ -4121,7 +4132,7 @@ end subroutine output contains include 'ftypeof.inc' include 'fesize.inc' - + include 'fvkind.inc' end subroutine vector_dump_to diff --git a/src/ast.f90 b/src/ast.f90 index 5d5654f..cb82223 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -81,6 +81,8 @@ module pm_ast integer,parameter:: proc_coded_type=node_args+9 integer,parameter:: proc_numret=node_args+10 integer,parameter:: proc_result_types=node_args+11 + + ! Alternative final sections for 'proc' parse nodes @@ -420,7 +422,10 @@ recursive subroutine dump_parse_tree(context,iunit,ptr,depth) return endif if(pm_fast_vkind(ptr)==pm_pointer) then - if(ptr%data%ptr(ptr%offset)%offset/=9876) then + if(ptr%offset<=0) then + write(iunit,*) spaces(1:depth*2),'INVALID PTR' + return + elseif(ptr%data%ptr(ptr%offset)%offset/=9876) then if(ptr%data%ptr(ptr%offset)%offset==9875) then write(iunit,*) spaces(1:depth*2),'REUSED NODE',& ptr%offset,ptr%data%hash,ptr%data%esize diff --git a/src/cfortran.f90 b/src/cfortran.f90 index 2a1a2b4..38a313f 100644 --- a/src/cfortran.f90 +++ b/src/cfortran.f90 @@ -5558,7 +5558,7 @@ recursive subroutine outpack(tno,varname,depth) call out_line(g,'END SELECT') case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_type_is_all,pm_type_is_par_kind,pm_type_is_enveloped,& + case(pm_type_is_all,pm_type_is_par_kind,& pm_type_is_vect) call outpack(pm_tv_arg(tv,1),varname,depth) end select @@ -5682,7 +5682,7 @@ recursive subroutine outunpack(tno,varname,depth) call out_line(g,'END SELECT') case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_type_is_all,pm_type_is_par_kind,pm_type_is_enveloped,& + case(pm_type_is_all,pm_type_is_par_kind,& pm_type_is_vect) call outunpack(pm_tv_arg(tv,1),varname,depth) end select @@ -5857,7 +5857,7 @@ recursive subroutine outcount(g,tno,varname,depth) enddo case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_type_is_all,pm_type_is_par_kind,pm_type_is_enveloped,& + case(pm_type_is_all,pm_type_is_par_kind,& pm_type_is_vect) call outcount(g,pm_tv_arg(tv,1),varname,depth) end select diff --git a/src/cnodes.f90 b/src/cnodes.f90 index ab73724..555fc8e 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -23,6 +23,23 @@ ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN ! THE SOFTWARE. +!================================================ +! Middle-level Intermediate representation +!------------------------------------------------ +! The structure is built of cnodes: +! proc - user defined procedure +! builtin - intrinsic (built-in) procedure +! cblock - list of calls +! call - either linked to a signature +! (list of argument types and procedures) +! or flagged as a "special" call +! - argument list refers to var, const, and +! cblock cnodes +! - control stuctures = calls with cblock args +! var - vars and runtime consts +! const - literal constants +!================================================ + module pm_cnodes use pm_kinds @@ -35,10 +52,11 @@ module pm_cnodes use pm_symbol use pm_types use pm_ast - use pm_sysdefs + + implicit none ! Debug cnode operations - logical,parameter:: debug_cnodes=.false. + logical,parameter:: debug_cnodes=.true. ! Magic number for code tree nodes integer,parameter:: cnode_magic_no=10456_pm_p @@ -63,10 +81,11 @@ module pm_cnodes integer,parameter:: cnode_is_arg_constraint=9 integer,parameter:: cnode_is_par_constraint=10 integer,parameter:: cnode_is_type_constraint=11 - !integer,parameter:: cnode_is_interface_constraint=12 - integer,parameter:: cnode_is_any_sig=13 - integer,parameter:: cnode_is_autoconv_sig=14 - integer,parameter:: cnode_num_kinds=14 + integer,parameter:: cnode_is_any_sig=12 + integer,parameter:: cnode_is_autoconv_sig=13 + integer,parameter:: cnode_is_changelist=14 + integer,parameter:: cnode_is_callsig=15 + integer,parameter:: cnode_num_kinds=15 ! Offsets into cblock cnodes integer,parameter:: cblock_parent=cnode_args+0 @@ -88,18 +107,19 @@ module pm_cnodes ! Offsets into call cnodes integer,parameter:: call_args=cnode_args+0 - integer,parameter:: call_parent=cnode_args+1 - integer,parameter:: call_sig=cnode_args+2 - integer,parameter:: call_flags=cnode_args+3 - integer,parameter:: call_link=cnode_args+4 - integer,parameter:: call_back_link=cnode_args+5 - integer,parameter:: call_nret=cnode_args+6 - integer,parameter:: call_nkeys=cnode_args+7 - integer,parameter:: call_index=cnode_args+8 - integer,parameter:: call_par_depth=cnode_args+9 - integer,parameter:: call_var=cnode_args+10 - integer,parameter:: call_amp=cnode_args+11 - integer,parameter:: call_node_size=12 + integer,parameter:: call_keys=cnode_args+1 + integer,parameter:: call_parent=cnode_args+2 + integer,parameter:: call_sig=cnode_args+3 + integer,parameter:: call_flags=cnode_args+4 + integer,parameter:: call_link=cnode_args+5 + integer,parameter:: call_back_link=cnode_args+6 + integer,parameter:: call_nret=cnode_args+7 + integer,parameter:: call_key_names=cnode_args+8 + integer,parameter:: call_index=cnode_args+9 + integer,parameter:: call_par_depth=cnode_args+10 + integer,parameter:: call_var=cnode_args+11 + integer,parameter:: call_amp=cnode_args+12 + integer,parameter:: call_node_size=13 ! Offsets into var cnodes integer,parameter:: var_parent=cnode_args+0 @@ -109,7 +129,7 @@ module pm_cnodes integer,parameter:: var_index=cnode_args+4 integer,parameter:: var_par_depth=cnode_args+5 integer,parameter:: var_create_depth = cnode_args + 6 - integer,parameter:: var_if_scope = cnode_args + 7 + integer,parameter:: var_lex_scope = cnode_args + 7 integer,parameter:: var_node_size=8 integer,parameter:: var_extra_info=cnode_args+8 @@ -131,31 +151,36 @@ module pm_cnodes integer,parameter:: var_is_no_import_export=32768 integer,parameter:: var_is_sync=65536 - ! Offsets into proc nodes - integer,parameter:: pr_cblock=cnode_args+0 - integer,parameter:: pr_max_index=cnode_args+1 - integer,parameter:: pr_recurse=cnode_args+2 - integer,parameter:: pr_id=cnode_args+3 - integer,parameter:: pr_rtype=cnode_args+4 ! Must be same as bi_rtype - integer,parameter:: pr_nargs=cnode_args+5 - integer,parameter:: pr_nkeys=cnode_args+6 - integer,parameter:: pr_nret=cnode_args+7 - integer,parameter:: pr_flags=cnode_args+8 - integer,parameter:: pr_name=cnode_args+9 - integer,parameter:: pr_ncalls=cnode_args+10 - integer,parameter:: pr_tkeys=cnode_args+11 - integer,parameter:: pr_node_size=12 - - ! Offsets into builtin nodes - integer,parameter:: bi_opcode=cnode_args+0 - integer,parameter:: bi_opcode2=cnode_args+1 - integer,parameter:: bi_data=cnode_args+2 - integer,parameter:: bi_flags=cnode_args+3 - integer,parameter:: bi_rtype=cnode_args+4 ! Must be same as pr_rtype - integer,parameter:: bi_rcode=cnode_args+5 - integer,parameter:: bi_rsym=cnode_args+6 - integer,parameter:: bi_id=cnode_args+7 - integer,parameter:: bi_node_size=8 + ! Offsets into proc & builtin nodes + integer,parameter:: pr_ptype=cnode_args+0 + integer,parameter:: pr_rtype=cnode_args+1 + integer,parameter:: pr_nargs=cnode_args+2 + integer,parameter:: pr_nret=cnode_args+3 + integer,parameter:: pr_flags=cnode_args+4 + integer,parameter:: pr_amps=cnode_args+5 + integer,parameter:: pr_name=cnode_args+6 + + ! Offets into proc nodes only + integer,parameter:: pr_cblock=cnode_args+7 + integer,parameter:: pr_max_index=cnode_args+8 + integer,parameter:: pr_recurse=cnode_args+9 + integer,parameter:: pr_id=cnode_args+10 + integer,parameter:: pr_ncalls=cnode_args+11 + integer,parameter:: pr_keys=cnode_args+12 + integer,parameter:: pr_keycall=cnode_args+13 + integer,parameter:: pr_argcall=cnode_args+14 + integer,parameter:: pr_node_size=15 + + ! Offsets into builtin nodes only + integer,parameter:: bi_opcode=cnode_args+7 + integer,parameter:: bi_opcode2=cnode_args+8 + integer,parameter:: bi_id=cnode_args+9 + integer,parameter:: bi_node_size=10 + + integer(pm_p),parameter:: spsig_thru=-4_pm_p + integer(pm_p),parameter:: spsig_dup=-5_pm_p + integer(pm_p),parameter:: spsig_noop=-6_pm_p + contains @@ -446,6 +471,13 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& sig_cache,cnode_arg(cnode,1)) write(iunit,'(a)') '}' + case(cnode_is_callsig) + write(iunit,'(a)') 'sig{' + do i=1,cnode_numargs(cnode) + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode_arg(cnode,i)) + enddo + write(iunit,'(a)') '}' case(cnode_is_arglist) write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'{' if(cnode_flags_set(cnode,cnode_args+1,proc_is_var)) then @@ -479,6 +511,13 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) enddo write(iunit,'(a)') '}' + case(cnode_is_builtin) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//'] {' + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode) + write(iunit,'(a)') '}' + case default + write(iunit,'("????",i5)') kind end select else call pm_dump_tree(context,iunit,cnode,1) @@ -493,23 +532,20 @@ subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) integer,intent(in):: iunit type(pm_ptr),intent(in):: rvec,sig_cache,cnode integer:: flags + + write(iunit,'(a)') ' '//& + trim(pm_name_as_string(context,cnode_get_num(cnode,pr_name)))//& + trim(pm_type_as_string(context,cnode_get_num(cnode,pr_ptype)))//' {' + if(cnode_get_kind(cnode)==cnode_is_builtin) then - if(cnode_get_num(cnode,cnode_args)>=0) then - write(iunit,'(a)') ' Builtin '//& - op_names(cnode_get_num(cnode,cnode_args))//& - pm_int_as_string(cnode_get_num(cnode,cnode_args+1))//'{' - else - write(iunit,'(a)') ' Fold {' - if(.not.pm_fast_isnull(cnode_get(cnode,bi_rcode))) then - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,bi_rcode),4) - endif - endif - write(iunit,'(a)') ' }' + write(iunit,'(a)') ' Builtin '//& + op_names(cnode_get_num(cnode,bi_opcode))//& + pm_int_as_string(cnode_get_num(cnode,bi_opcode2)) else - write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & + + write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & ' [nargs=',& - cnode_get_num(cnode,pr_nargs),',nkeys=',& - cnode_get_num(cnode,pr_nkeys),',nret=',cnode_get_num(cnode,pr_nret),& + cnode_get_num(cnode,pr_nargs),',nret=',cnode_get_num(cnode,pr_nret),& ',ncalls=',cnode_get_num(cnode,pr_ncalls),']' if(cnode_flags_set(cnode,pr_flags,proc_is_comm)) & write(iunit,'(a)') ' [loop]' @@ -523,13 +559,15 @@ subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) write(iunit,'(a)') ' [empty-each]' flags=cnode_get_kind(cnode) !write(*,*) 'Kind=',flags - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_arg(cnode,1),4) + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,pr_cblock),4) endif + + write(iunit,'(a)') ' }' contains include 'fisnull.inc' end subroutine print_proc_cnode - subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) + recursive subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) type(pm_context),pointer:: context integer,intent(in):: iunit,depth type(pm_ptr),intent(in):: rvec,sig_cache,cnode @@ -543,16 +581,16 @@ subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) include 'fisnull.inc' end subroutine print_cblock_cnode - subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) + recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) type(pm_context),pointer:: context integer,intent(in):: iunit,depth type(pm_ptr),intent(in):: rvec,sig_cache,cnode integer:: signo,name,i,j,k,nret,nargs,modl,line - type(pm_ptr):: p,args,amps + type(pm_ptr):: p,args,amps,keys,keynames character(len=120):: str,location signo=cnode_get_num(cnode,call_sig) if(signo<0) then - str=repeat(' ',depth)//pm_name_as_string(context,-signo) + str=repeat(' ',depth)//trim(pm_int_as_string(cnode_get_num(cnode,call_par_depth)+1))//' '//pm_name_as_string(context,-signo) i=len_trim(str)+1 if(.not.pm_fast_isnull(rvec)) then k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) @@ -561,6 +599,8 @@ subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) '['//trim(pm_int_as_string(k))//'] ',.false.,depth) endif endif + elseif(signo==0) then + call append_to_line(iunit,str,i,' VAR-CALL ',.false.,depth) else p=pm_dict_key(context,sig_cache,& int(signo,pm_ln)) @@ -585,8 +625,8 @@ subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) str=repeat(' ',depth)//'call [noop]'//& pm_name_as_string(context,name) elseif(k<0) then - str=repeat(' ',depth)//'call [??]'//& - pm_name_as_string(context,name) + str=repeat(' ',depth)//'call '//'!![-'//trim(pm_int_as_string(-k))//']'& + //pm_name_as_string(context,name) else str=repeat(' ',depth)//'call '//'['//trim(pm_int_as_string(k))//']'& //pm_name_as_string(context,name) @@ -621,6 +661,18 @@ subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) i=i+1 enddo + keys=cnode_get(cnode,call_keys) + if(.not.pm_fast_isnull(keys)) then + + keynames=pm_name_val(context,cnode_get_num(cnode,call_key_names)) + do j=1,cnode_numargs(keys) + call append_to_line(iunit,str,i,& + trim(pm_name_as_string(context,keynames%data%i(keynames%offset+j-1))),.false.,depth) + call append_to_line(iunit,str,i,':=:'//trim(pm_name_as_string(context,name))//':',.false.,depth) + call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(keys,j),depth,str,i) + i=i+1 + enddo + endif modl=cnode_get_num(cnode,cnode_modl_name) line=cnode_get_num(cnode,cnode_lineno) location=trim(pm_name_as_string(context,modl))//':'//pm_int_as_string(line) @@ -632,13 +684,14 @@ subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) include 'fisnull.inc' end subroutine print_call_cnode - subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) + recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) type(pm_context),pointer:: context integer,intent(in):: iunit,depth type(pm_ptr),intent(in):: rvec,sig_cache,cnode character(len=*),intent(inout):: str integer,intent(inout):: i integer:: kind,name,tno + type(pm_ptr):: p kind=pm_fast_vkind(cnode) if(kind==pm_tiny_int) then call append_to_line(iunit,str,i,& @@ -663,6 +716,10 @@ subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) else call append_quoted_to_line(iunit,str,i,& trim(pm_name_as_string(context,name)),.false.,depth) + if(.not.cnode_flags_clear(cnode,var_flags,var_is_imported+var_is_shadowed)) then + call append_to_line(iunit,str,i,''''//& + trim(pm_int_as_string(cnode_get_num(cnode,var_index))),.false.,depth) + endif endif if(.not.pm_fast_isnull(rvec)) then tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) @@ -678,6 +735,26 @@ subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) str=' ' str(depth+1:depth+1)='}' i=depth+1 + case(cnode_is_changelist) + call append_to_line(iunit,str,i,'^(',.false.,depth) + p=cnode_arg(cnode,1) + do while(.not.pm_fast_isnull(p)) + call print_value_cnode(context,iunit,rvec,sig_cache,p%data%ptr(p%offset),depth,str,i) + p=p%data%ptr(p%offset+1) + if(.not.pm_fast_isnull(p)) then + call append_to_line(iunit,str,i,',',.false.,depth) + endif + enddo + call append_to_line(iunit,str,i,') &(',.false.,depth) + p=cnode_arg(cnode,2) + do while(.not.pm_fast_isnull(p)) + call print_value_cnode(context,iunit,rvec,sig_cache,p%data%ptr(p%offset),depth,str,i) + p=p%data%ptr(p%offset+1) + if(.not.pm_fast_isnull(p)) then + call append_to_line(iunit,str,i,',',.false.,depth) + endif + enddo + call append_to_line(iunit,str,i,')',.false.,depth) end select endif contains diff --git a/src/codegen.f90 b/src/codegen.f90 index e88904d..0f06153 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -26,6 +26,7 @@ !================================================ ! The following routines process the parse tree ! into an intermediate form representation +! (defined in pm_cnodes) !------------------------------------------------ ! The new structure is built of cnodes: ! proc - user defined procedure @@ -52,7 +53,6 @@ module pm_codegen use pm_symbol use pm_types use pm_ast - use pm_sysdefs use pm_cnodes implicit none @@ -116,11 +116,6 @@ module pm_codegen integer,parameter:: typevar_start=-4 integer,parameter:: typevar_end=-5 - ! Must match definitions in infer - integer(pm_p),parameter:: spsig_thru=-4_pm_p - integer(pm_p),parameter:: spsig_dup=-5_pm_p - integer(pm_p),parameter:: spsig_noop=-6_pm_p - ! Maximum number of coding errors before exit integer,parameter:: max_code_errors = 20 @@ -196,13 +191,16 @@ module pm_codegen integer:: index ! Nesting depth of if statements (offset into vstack) - integer:: if_scope + integer:: lex_scope ! Flags indicating type inference not complete logical:: types_finished,redo_calls,incomplete,first_pass ! Taints integer:: taints,proc_taints + + ! Type inference base of current proc record + integer:: base ! This is the parallel kind storeageless implicit argument integer:: par_kind,par_kind2 @@ -214,6 +212,7 @@ module pm_codegen type(pm_ptr),dimension(max_par_depth):: trace integer,dimension(max_par_depth)::trace_keys integer:: trace_depth + ! Error count type(pm_ptr):: error_nodes(max_error_nodes) @@ -267,7 +266,7 @@ subroutine init_coder(context,coder,visibility) coder%loop_cblock=pm_null_obj coder%proc_keys=pm_null_obj coder%index=0 - coder%if_scope=0 + coder%lex_scope=0 coder%true=pm_new_small(context,pm_logical,1_pm_p) coder%true%data%l(coder%true%offset)=.true. coder%false=pm_new_small(context,pm_logical,1_pm_p) @@ -351,10 +350,6 @@ subroutine trav_prog(coder,stmt_list) call close_cblock(coder,prog_cblock) if(coder%num_errors/=0) return - - ! Finalise any var calls - call complete_vcall_sigs(coder) - if(coder%num_errors/=0) return ! Complete type definitions call complete_type_checks(coder) @@ -364,7 +359,6 @@ subroutine trav_prog(coder,stmt_list) ! Sort signatures call sort_sigs(coder) - contains include 'fnewnc.inc' include 'fname.inc' @@ -399,7 +393,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& listp,list) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,listp,list - integer:: i,j,n,sym,base,vbase,wbase + integer:: i,j,n,sym,base,vbase,wbase,lex_scope integer:: save_par_state,save_over_base,save_run_flags type(pm_ptr):: node,cblock2,var,p logical:: iscomm,isshared,ok,oldfix @@ -416,7 +410,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& select case(sym) case(sym_if) save_par_state=coder%par_state - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) call trav_xexpr(coder,cblock,node,& node_arg(node,1)) if(coder%par_state>par_state_outer) then @@ -426,7 +420,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& coder%par_state=par_state_cond endif endif - coder%if_scope=j + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& node_arg(node,2),sym_if) if(.not.pm_fast_isnull(node_arg(node,3))) then @@ -435,21 +429,21 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif - n=get_if_scope(coder) + call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,& - sym_if,3+n,0) - call pop_if_scope(coder) + sym_if,4,0) + call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_if_invar) if(coder%par_state>=par_state_cond) then call code_error(coder,node,& 'Cannot have "if invar" in a conditional context') endif - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) call trav_xexpr(coder,cblock,node,& node_arg(node,1)) call code_check_invar(coder,cblock,node,top_code(coder)) - coder%if_scope=j + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& node_arg(node,2),sym_if_invar) if(.not.pm_fast_isnull(node_arg(node,3))) then @@ -458,9 +452,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif - n=get_if_scope(coder) - call make_sp_call(coder,cblock,node,sym,3+n,0) - call pop_if_scope(coder) + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,sym,4,0) + call pop_lex_scope(coder) case(sym_switch) save_par_state=coder%par_state call trav_xexpr(coder,cblock,node,& @@ -492,7 +486,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call drop_code(coder) case(sym_while,sym_while_invar) save_par_state=coder%par_state - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) call make_const(coder,cblock,node,node_arg(node,1)) cblock2=make_cblock(coder,cblock,node,sym_while) call trav_xexpr(coder,cblock2,node,node_arg(node,2)) @@ -501,23 +495,23 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& endif call close_cblock(coder,cblock2) coder%par_state=save_par_state - coder%par_state=par_state_for_loop(coder,node,coder%par_state,& - node_get_num(node,node_args)/=0,sym==sym_while_invar) - coder%if_scope=j +!!$ coder%par_state=par_state_for_loop(coder,node,coder%par_state,& +!!$ node_get_num(node,node_args)/=0,sym==sym_while_invar) + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& node_arg(node,3),sym_while) - n=get_if_scope(coder) - call make_sp_call(coder,cblock,node,sym_while,4+n,0) - call pop_if_scope(coder) + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,sym_while,5,0) + call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_until,sym_until_invar) - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) call make_const(coder,cblock,node,node_arg(node,1)) save_par_state=coder%par_state - coder%par_state=par_state_for_loop(coder,node,coder%par_state,& - node_get_num(node,node_args)/=0,sym==sym_until_invar) +!!$ coder%par_state=par_state_for_loop(coder,node,coder%par_state,& +!!$ node_get_num(node,node_args)/=0,sym==sym_until_invar) cblock2=make_cblock(coder,cblock,node,sym_until) - coder%if_scope=j + coder%lex_scope=lex_scope call trav_open_stmt_list(coder,cblock2,node,& node_arg(node,3)) iscomm=cnode_flags_set(top_code(coder),cblock_flags,cblock_is_comm) @@ -526,19 +520,14 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call code_check_invar(coder,cblock2,node,top_code(coder)) endif call close_cblock(coder,cblock2) - n=get_if_scope(coder) + call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,& - sym_until,3+n,0) - call pop_if_scope(coder) + sym_until,4,0) + call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_do_stmt) call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) call make_sp_call(coder,cblock,node,sym_do,1,0) - case(sym_after) - call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_do) - call make_sp_call(coder,cblock,node,sym_do,1,0) - call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) - call make_sp_call(coder,cblock,node,sym_do,1,0) case(sym_proceed) continue case(sym_mode) @@ -547,8 +536,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_xexpr(coder,cblock,node,node_arg(node,2),node) case(sym_each,sym_foreach_invar) call trav_xexpr(coder,cblock,node,node_arg(node,1),node) - case(sym_nhd) - call trav_xexpr(coder,cblock,node,node_arg(node,4),node) case(sym_test) if(pm_fast_isnull(node_arg(node,1))) then call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_check) @@ -567,7 +554,8 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_call(coder,cblock,node,p,0,.true.) case(sym_var,sym_const) do j=1,node_numargs(node)-1 - call make_var(coder,cblock,node,node_arg(node,j),ior(var_is_not_inited,& + call make_var(coder,cblock,node,node_arg(node,j),& + ior(var_is_not_inited,& merge(var_is_var,0,sym==sym_var))) enddo call push_word(coder,pm_type_new_uninitialised) @@ -586,7 +574,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_open_stmt_list(coder,cblock,node,node_arg(node,2)) call hide_vars(coder,base+1,j) case(sym_over) - call trav_over_stmt(coder,cblock,list,node) +! call trav_over_stmt(coder,cblock,list,node) case(sym_define) call trav_assign_define(coder,cblock,list,node) case(sym_assign_list) @@ -627,7 +615,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call pm_panic('Unknown par state (sym_sync)') end select case(sym_par) - call trav_par_stmt(coder,cblock,list,node) + ! call trav_par_stmt(coder,cblock,list,node) case(sym_any,sym_any_invar) call trav_any_stmt(coder,cblock,list,node,sym) case(sym_ddollar) @@ -657,9 +645,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call code_error(coder,node,& '"$$dump" takes one or two arguments',warn=.true.) else - if(coder%par_state/=par_state_outer) then - call make_comm_call_args(coder,cblock,node) - endif call trav_expr(coder,cblock,node,node_arg(node,2)) if(j==3) call trav_expr(coder,cblock,node,node_arg(node,3)) if(coder%par_state==par_state_outer) then @@ -794,56 +779,59 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& include 'fname.inc' end subroutine trav_open_stmt_list - !=================================== - ! Create a new scope for an if - ! statement (used to identify - ! variables defined outside the - ! statement that are modified - ! within it) + !================================================ + ! Create a new lexical scope (used to identify + ! variables defined outside the statement that + ! are accessed or modified within it) ! Pushes small record on vstack - !=================================== - function push_if_scope(coder) result(new_if_scope) + !================================================ + function push_lex_scope(coder) result(new_lex_scope) type(code_state),intent(inout):: coder - integer:: new_if_scope - call code_num(coder,coder%if_scope) + integer:: new_lex_scope + call code_num(coder,coder%lex_scope) call code_null(coder) - new_if_scope=coder%vtop - end function push_if_scope + call code_null(coder) + new_lex_scope=coder%vtop + end function push_lex_scope - !================================== - ! Get the changes if current if-scope - !================================== - function get_if_scope(coder) result(n) + !=========================================== + ! Push change lists of current lexical scope + ! as a changelist cnode + !=========================================== + subroutine get_lex_scope(coder,node) type(code_state),intent(inout):: coder - integer:: n - call retrieve_change_list(coder,coder%vstack(coder%if_scope),n) - end function get_if_scope + type(pm_ptr),intent(in):: node + call code_val(coder,coder%vstack(coder%lex_scope)) + call code_val(coder,coder%vstack(coder%lex_scope-1)) + call make_code(coder,node,cnode_is_changelist,2) + end subroutine get_lex_scope - !================================ - ! Exit if-statement scope - !================================ - subroutine pop_if_scope(coder) + !=================================== + ! Exit lexical scope + ! Pops record off the top of vstack + !=================================== + subroutine pop_lex_scope(coder) type(code_state),intent(inout):: coder - coder%if_scope=coder%vstack(coder%vtop-1)%offset + coder%lex_scope=coder%vstack(coder%vtop-2)%offset + call drop_code(coder) call drop_code(coder) call drop_code(coder) - end subroutine pop_if_scope + end subroutine pop_lex_scope !============================================= ! Add var to the change list for all if scopes ! that are nested inside the scope in which ! the variable was defined !============================================= - subroutine update_change_lists(coder,var) + subroutine update_change_lists(coder,var,modify) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: var - integer:: if_scope - if_scope=coder%if_scope - do while(cnode_get_num(var,var_if_scope)1) call swap_code_2_1(coder) - endif - call make_temp_var(coder,cblock,stmt) - call dup_code(coder) call code_val(coder,var) call code_val(coder,coder%vstack(base+i)) - call make_sys_call(coder,cblock,stmt,& + call make_sys_call_rtn(coder,cblock,stmt,& sym_checkcase,2,1) if(i>1) then - call make_sys_call(coder,cblock,stmt,& + call make_sys_call_rtn(coder,cblock,stmt,& sym_or,2,1) endif enddo @@ -1074,7 +1051,7 @@ recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) if(sym==sym_if_invar) then call code_check_invar(coder,cblock,stmt,top_code(coder)) endif - coder%if_scope=j + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,stmt,& node_arg(stmt,idx+1),sym_switch) if(idx==node_numargs(stmt)-2) then @@ -1089,9 +1066,9 @@ recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) call trav_switch_stmt(coder,cblock2,stmt,idx+2,var,sym) call close_cblock(coder,cblock2) endif - n=get_if_scope(coder) - call make_sp_call(coder,cblock,stmt,sym,3+n,0) - call pop_if_scope(coder) + call get_lex_scope(coder,stmt) + call make_sp_call(coder,cblock,stmt,sym,4,0) + call pop_lex_scope(coder) contains include 'fisnull.inc' end subroutine trav_switch_stmt @@ -1141,11 +1118,11 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: sym - integer:: k,i,j,n,flags,start,finish,vb + integer:: k,i,j,n,flags,start,finish,vb,lex_scope type(pm_ptr):: cblock2,vlist,v,var integer:: save_par_state - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) if(pm_fast_isnull(node_arg(node,2))) then flags=var_is_shadowed+var_is_var @@ -1167,14 +1144,12 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) var=top_code(coder) start=coder%index call swap_code(coder) - coder%if_scope=j + coder%lex_scope=lex_scope call trav_open_stmt_list(coder,cblock2,node,node_arg(node,3)) if(cnode_flags_set(var,var_flags,var_is_changed)) then - call make_temp_var(coder,cblock2,node) - call dup_code(coder) call code_val(coder,var) call dup_expr(coder,v) - call make_sys_call(coder,cblock2,node,sym_as,2,1) + call make_sys_call_rtn(coder,cblock2,node,sym_as,2,1) call hide_vars(coder,vb,vb) if(pm_fast_isnull(node_arg(node,2))) then call make_assignment_noalias(coder,cblock2,node,node_arg(node,1)) @@ -1187,15 +1162,15 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) call close_cblock(coder,cblock2) call code_val(coder,v) v=pm_fast_newnc(coder%context,pm_int,2) - coder%temp=v + coder%temp2=v v%data%i(v%offset)=start v%data%i(v%offset+1)=finish - call make_const(coder,cblock,node,coder%temp) - n=get_if_scope(coder) - call make_sp_call(coder,cblock,node,sym_any,3+n,1) + call make_const(coder,cblock,node,coder%temp2) + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,sym_any,4,1) call drop_code(coder) call hide_vars(coder,vb,vb) - call pop_if_scope(coder) + call pop_lex_scope(coder) coder%par_state=save_par_state contains include 'fisnull.inc' @@ -1215,7 +1190,7 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba type(pm_ptr):: var,vlist type(pm_ptr):: cblock2,cblock3,cblock4 type(pm_ptr):: cblock_main - integer:: i,j,k,n,lbase,vbase,xbase,xbasev + integer:: i,j,k,n,lbase,vbase,xbase,xbasev,lex_scope integer:: nlist,iter,iter2,sym,rbase,wbase,name,flags,sindex,sbase integer:: slot1,slot2,while_var,outmode,rflags integer(pm_p)::flag @@ -1232,7 +1207,7 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba if(debug_codegen) write(*,*) 'TRAVEACH>' - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) rbase=coder%vtop ! Process iterator expression @@ -1256,9 +1231,9 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba endif save_par_state=coder%par_state - coder%par_state=par_state_for_loop(coder,stmt,coder%par_state,& - node_get_num(stmt,node_args+3)/=0,sym==sym_foreach_invar) - +!!$ coder%par_state=par_state_for_loop(coder,stmt,coder%par_state,& +!!$ node_get_num(stmt,node_args+3)/=0,sym==sym_foreach_invar) +!!$ ! Start for-each loop iter=call_start(coder,cblock,list,invar) @@ -1277,19 +1252,17 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba if(.not.pm_fast_isnull(node_arg(stmt,2))) then p=node_arg(stmt,2) if(node_sym(p)==sym_while) then - call make_temp_var(coder,cblock,stmt) - call dup_code(coder) call code_val(coder,coder%var(iter+lv_end)) call trav_xexpr(coder,cblock,p,node_arg(p,1)) if(invar) then call code_check_invar(coder,cblock,p,top_code(coder)) endif - call make_sys_call(coder,cblock,stmt,sym_and,2,1,aflags=rflags) + call make_sys_call_rtn(coder,cblock,stmt,sym_and,2,1,aflags=rflags) call make_var_assignment(coder,cblock,stmt,coder%var(iter+lv_end),aflags=rflags) endif endif - coder%if_scope=j + coder%lex_scope=lex_scope ! Loop body cblock2=make_cblock(coder,cblock,list,sym_each) @@ -1312,12 +1285,12 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba ! While/until p=node_arg(stmt,2) if(node_sym(p)/=sym_while) then - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) call trav_xexpr(coder,cblock2,stmt,node_arg(p,1)) if(sym==sym_foreach_invar) then call code_check_invar(coder,cblock2,p,top_code(coder)) endif - coder%if_scope=j + coder%lex_scope=lex_scope cblock_main=make_cblock(coder,cblock2,stmt,sym_each) call make_const(coder,cblock_main,stmt,coder%false) call make_var_assignment(coder,cblock_main,stmt,& @@ -1326,9 +1299,9 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba cblock_main=make_cblock(coder,cblock2,stmt,sym_each) call call_next(coder,cblock_main,list,iter,invar) call close_cblock(coder,cblock_main) - n=get_if_scope(coder) - call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),3+n,0) - call pop_if_scope(coder) + call get_lex_scope(coder,stmt) + call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),4,0) + call pop_lex_scope(coder) else call call_next(coder,cblock2,list,iter,invar) endif @@ -1337,16 +1310,14 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba endif ! Get elements for next iteration - j=push_if_scope(coder) + lex_scope=push_lex_scope(coder) call code_val(coder,coder%var(iter+lv_end)) - coder%if_scope=j + coder%lex_scope=lex_scope cblock_main=make_cblock(coder,cblock2,stmt,sym_each) do i=1,nlist/2 - call make_temp_var(coder,cblock_main,stmt) - call dup_code(coder) call code_val(coder,coder%vstack(lbase+i)) call code_val(coder,coder%var(iter+lv_idx)) - call make_sys_call(coder,cblock_main,list,sym_get_element,2,1,aflags=rflags) + call make_sys_call_rtn(coder,cblock_main,list,sym_get_element,2,1,aflags=rflags) call make_var_assignment(coder,cblock_main,stmt,coder%var(xbase+i),aflags=rflags) enddo if(.not.pm_fast_isnull(node_arg(stmt,2))) then @@ -1362,15 +1333,15 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba endif call close_cblock(coder,cblock_main) call code_null(coder) - n=get_if_scope(coder) - call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),3+n,0) - call pop_if_scope(coder) + call get_lex_scope(coder,stmt) + call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),4,0) + call pop_lex_scope(coder) call close_cblock(coder,cblock2) ! Build call call code_val(coder,coder%var(iter+lv_end)) - n=get_if_scope(coder) - call make_sp_call(coder,cblock,list,sym_each,3+n,0) + call get_lex_scope(coder,stmt) + call make_sp_call(coder,cblock,list,sym_each,4,0) ! Clean up coder%par_state=save_par_state @@ -1378,7 +1349,7 @@ recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nba call pop_vars_to(coder,vbase) - call pop_if_scope(coder) + call pop_lex_scope(coder) contains include 'fisnull.inc' @@ -1407,15 +1378,9 @@ function call_start(coder,cblock,list,invar) result(iter) iter=coder%top - ! Code iter,state,not_end=first(domain) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) + ! Code iter,state,not_end=first(domain) call code_val(coder,coder%var(iter)) - call make_sys_call(coder,cblock,list,sym_first,1,3) + call make_sys_call_rtn(coder,cblock,list,sym_first,1,3) ! Loop end call define_sys_var(coder,cblock,list,sym_for_stmt,& @@ -1460,16 +1425,10 @@ subroutine call_next(coder,cblock,list,iter,invar) ivar=coder%var(iter+lv_idx) svar=coder%var(iter+lv_state) evar=coder%var(iter+lv_end) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) call code_val(coder,dvar) call code_val(coder,svar) call code_val(coder,ivar) - call make_sys_call(coder,cblock,list,sym_next,3,3) + call make_sys_call_rtn(coder,cblock,list,sym_next,3,3) call make_var_assignment(coder,cblock,list,evar) call make_var_assignment(coder,cblock,list,svar) call make_var_assignment(coder,cblock,list,ivar) @@ -1480,6 +1439,52 @@ subroutine call_next(coder,cblock,list,iter,invar) end subroutine call_next + + subroutine check_par_context(coder,list_head,node,cond_is_ok) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: list_head,node + logical,intent(in):: cond_is_ok + type(pm_ptr):: list + integer:: i + select case(coder%par_state) + case(par_state_for,par_state_loop,par_state_masked,par_state_over,& + par_state_labelled) + continue + case(par_state_outer) + call code_error(coder,node,& + 'Cannot have communicating operation outside of any parallel statement') + return + case(par_state_nhd) + call code_error(coder,node,& + 'Cannot have communicating operation in the main body of a "nhd" statement') + return + case(par_state_any) + if(.not.cond_is_ok) then + call code_error(coder,node,& + 'Cannot have active communicating operation in an "any" statement') + endif + case(par_state_cond) + if(.not.cond_is_ok) then + call code_error(coder,node,& + 'Unlabelled communicating operation in conditional statement') + endif + case(par_state_cond_loop) + if(.not.cond_is_ok) then + call code_error(coder,node,& + 'Communicating operation in unlabelled loop') + endif + case(par_state_par) + if(.not.cond_is_ok) then + call code_error(coder,node,& + 'Unlabelled communicating operation in par statement') + endif + case default + write(*,*) 'Par state=',coder%par_state + call pm_panic('Unknown par state') + end select + end subroutine check_par_context + + !======================================================== ! Code a check if value is invariant !======================================================== @@ -1522,1325 +1527,229 @@ recursive subroutine trav_iter(coder,cblock,list,shape_sym,lbase,vbase,nlist) enddo ! Calculate common iteration domain from 1st element in list - call make_temp_var(coder,cblock,list) - call dup_code(coder) call repl_expr(coder,lbase+1) - call make_sys_call(coder,cblock,list,shape_sym,1,1) + call make_sys_call_rtn(coder,cblock,list,shape_sym,1,1) call define_sys_var(coder,cblock,list,sym_for,var_is_shadowed) end subroutine trav_iter - !=================================================================== - ! Work out the parallel state within a sequential loop - !=================================================================== - function par_state_for_loop(coder,node,oldstate,labelled,invar) result(newstate) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node - integer,intent(in):: oldstate - logical,intent(in):: labelled,invar - integer:: newstate - if(invar.and.oldstate==par_state_outer) then - call code_error(coder,node,& - 'Cannot have "invar" loop outside of a parallel context') - elseif(invar.and.oldstate==par_state_nhd) then - call code_error(coder,node,& - 'Cannot have "invar" loop in the main body of a "nhd" statement') - endif - - if(invar.and.labelled) then - call code_error(coder,node,& - 'An "invar" loop cannot be labelled') - endif - newstate=oldstate - if(oldstate>=par_state_cond.and.& - oldstate<=par_state_par) then - if(labelled) then - newstate=par_state_cond - else - newstate=par_state_cond_loop - endif - elseif(oldstate==par_state_for) then - newstate=par_state_loop - elseif(labelled) then - if(oldstate==par_state_outer) then - call code_error(coder,node,& - 'Cannot have labelled loop outside of any parallel context') - elseif(oldstate==par_state_nhd) then - call code_error(coder,node,& - 'Cannot have labelled loop in the main body of a "nhd" statement') - elseif(oldstate==par_state_cond_loop) then - call code_error(coder,node,& - 'Cannot have labelled loop inside unlabelled loop within conditional context') - endif - endif - end function par_state_for_loop + !************************************************** + ! PARALLEL STATEMENTS + !************************************************** - !============================== - ! Traverse a nhd statement - !============================== - recursive subroutine trav_nhd_stmt(coder,cblock,pnode,node,base) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer,intent(in):: base - type(pm_ptr):: list,namelist,loop,cblock2,cblock3,edges - integer:: i,j,k,iter,var,nlist,nvars - integer:: stmt_base,nhd_base,join_base,expr_base,env_base - integer:: nvar_base,block_base,bounds_base,over_base - integer:: save_par_state - ! node for nhd statement is - ! (nhd (name expr)*)*,bounds,attr,subexp,block +!!$ !======================================================== +!!$ ! Traverse par { } +!!$ !======================================================== +!!$ recursive subroutine trav_par_stmt(coder,cblock,pnode,node) +!!$ type(code_state),intent(inout):: coder +!!$ type(pm_ptr),intent(in):: cblock,pnode,node +!!$ type(pm_ptr):: let,clause,cblock_main,cblock_pre,cblock_post +!!$ type(pm_ptr):: vlist,save_loop_cblock +!!$ integer:: i,j,k,iter,istart,vstart,base,rbase,m +!!$ integer:: save_par_base,save_over_base,save_par_state +!!$ integer:: slot1,slot2 +!!$ integer:: name,flags +!!$ +!!$ vstart=coder%vtop +!!$ save_loop_cblock=coder%loop_cblock +!!$ save_par_base=coder%par_base +!!$ save_over_base=coder%over_base +!!$ save_par_state=coder%par_state +!!$ +!!$ base=coder%top +!!$ +!!$ if(node_numargs(node)==4) then +!!$ call code_error(coder,node,'"par" statement has only one branch') +!!$ coder%vtop=vstart +!!$ return +!!$ endif +!!$ +!!$ ! Variable sym_for +!!$ call make_long_const(coder,cblock,node,& +!!$ int((node_numargs(node)-2)/2,pm_ln)) +!!$ call make_sys_call_rtn(coder,cblock,node,sym_array,1,1) +!!$ call define_sys_var(coder,cblock,node,sym_for,var_is_shadowed) +!!$ +!!$ ! Partition the domain across processors +!!$ iter=code_par_scope_start(coder,cblock,node,coder%var(coder%top),& +!!$ node_arg(node,1),cblock_main,cblock_pre,sym_also,.false.) +!!$ +!!$ slot1=coder%index +!!$ +!!$ do i=3,node_numargs(node),2 +!!$ call make_long_const(coder,cblock_main,node,int((i-2)/2,pm_ln)) +!!$ call make_definition(coder,cblock_main,node,node_arg(node,i),0) +!!$ enddo +!!$ +!!$ coder%par_state=par_state_for +!!$ +!!$ ! statements before any branch +!!$ call trav_open_stmt_list(coder,cblock_main,node,node_arg(node,2)) +!!$ +!!$ coder%par_state=par_state_par +!!$ +!!$ ! branches +!!$ call branch(cblock_main,3) +!!$ +!!$ slot2=coder%index +!!$ +!!$ ! Build parallel statement call +!!$ call code_par_scope_end(coder,iter,node,cblock,cblock_main,& +!!$ cblock_pre,& +!!$ save_par_base,slot1,slot2,.false.,.false.) +!!$ +!!$ coder%vtop=vstart +!!$ coder%loop_cblock=save_loop_cblock +!!$ coder%par_base=save_par_base +!!$ coder%over_base=save_over_base +!!$ call pop_vars_to(coder,base) +!!$ contains +!!$ include 'fisnull.inc' +!!$ include 'ftiny.inc' +!!$ +!!$ recursive subroutine branch(cblock,i) +!!$ type(pm_ptr),intent(in):: cblock +!!$ integer,intent(in):: i +!!$ type(pm_ptr):: cblock4,cblock5 +!!$ type(pm_ptr):: prc_test_var +!!$ integer:: n +!!$ +!!$ ! Is this branch running on this processor? +!!$ call make_temp_var(coder,cblock,node) +!!$ prc_test_var=top_code(coder) +!!$ call make_long_const(coder,cblock,node,int((i-2)/2,pm_ln)) +!!$ call make_sys_call_rtn(coder,cblock,node,sym_tuple,1,1) +!!$ call code_val(coder,coder%var(iter+lv_here)) +!!$ call make_sys_call(coder,cblock,node,sym_eq,2,1) +!!$ +!!$ if(i/=cnode_numargs(node)-1) then +!!$ ! If statment (if running_here then ... endif) +!!$ coder%lex_scope=push_lex_scope(coder) +!!$ call code_val(coder,prc_test_var) +!!$ cblock4=make_cblock(coder,cblock,node,sym_also) +!!$ ! task clause +!!$ call trav_open_stmt_list(coder,cblock4,node,node_arg(node,i+1)) +!!$ call close_cblock(coder,cblock4) +!!$ cblock5=make_cblock(coder,cblock,node,sym_also) +!!$ ! remaining task clauses +!!$ call branch(cblock5,i+2) +!!$ call close_cblock(coder,cblock5) +!!$ call get_lex_scope(coder,node) +!!$ call make_sp_call(coder,cblock,node,sym_if,4,0) +!!$ call pop_lex_scope(coder) +!!$ else +!!$ ! task clause +!!$ call trav_open_stmt_list(coder,cblock,node,node_arg(node,i+1)) +!!$ endif +!!$ +!!$ end subroutine branch +!!$ +!!$ end subroutine trav_par_stmt - ! Last variable outside statement - stmt_base=coder%top - - ! Traverse bounds - call trav_expr(coder,cblock,node,node_arg(node_arg(node,2),1)) - call define_sys_var(coder,cblock,node,sym_bounds,var_is_shadowed) - bounds_base=coder%top - - ! Check bounds - call make_comm_call_args(coder,cblock,node) - call dup_expr(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,node_arg(node,2),sym_check_bounds,1,0) - - ! Traverse block attribute - call trav_expr(coder,cblock,node,node_arg(node_arg(node,3),1)) - call define_sys_var(coder,cblock,node,sym_sub,var_is_shadowed) - block_base=coder%top - - ! Traverse nhd expressions - ! Leave nhd descriptors on vstack above nhd_base - nhd_base=coder%vtop - list=node_arg(node,1) - nlist=node_numargs(list) - do i=1,nlist,2 - call make_temp_var(coder,cblock,list) - call dup_code(coder) - call make_comm_call_args(coder,cblock,node) - call trav_expr(coder,cblock,list,node_arg(list,i)) - call code_val(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,list,sym_pm_nhd,2,1) - enddo - ! Compute the envelope of the NHDs - call dup_expr(coder,coder%vstack(nhd_base+1)) - if(nlist<=3) then - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call make_sys_call(coder,cblock,node,sym_envelope,1,1,& - aflags=merge(proc_run_shared+proc_run_always+call_inline_when_compiling,& - 0,pm_is_compiling)) - else - do i=1,nlist/3 - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call dup_expr(coder,coder%vstack(nhd_base+i)) - call make_sys_call(coder,cblock,node,sym_envelope,2,1,& - aflags=merge(proc_run_shared+proc_run_always+call_inline_when_compiling,& - 0,pm_is_compiling)) - enddo - endif - call define_sys_var(coder,cblock,node,sym_envelope,var_is_shadowed) - env_base=coder%top - ! Compute active area taking account of boundaries - call make_sys_var(coder,cblock,node,sym_nhd_active,var_is_shadowed) - call code_val(coder,coder%var(coder%par_base+lv_dom)) - call code_val(coder,coder%var(env_base)) - call code_val(coder,coder%var(bounds_base)) - call make_sys_call(coder,cblock,node,sym_nhd_active,3,1,aflags=proc_run_shared+proc_run_always) - - ! Traverse expressions - expr_base=coder%vtop - do i=1,nlist,2 - namelist=node_arg(list,i+1) - do j=1,node_numargs(namelist),2 - call trav_expr(coder,cblock,node,node_arg(namelist,j+1)) - enddo - enddo - ! Hide any where clauses - if(base>=0) then - call hide_vars(coder,base+1,coder%top) - endif + !***************************************************** + ! ASSIGNMENTS AND VARIABLE DEFINITIONS + !***************************************************** + !======================================================== + ! Traverse single assignment or var/const definition + !======================================================== + recursive subroutine trav_assign_define(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: lhs,rhs + integer:: n,sym,base + base=coder%vtop + lhs=node_arg(node,1) + rhs=node_arg(node,2) + sym=node_sym(lhs) + n=node_numargs(lhs) + if(sym/=sym_define) n=n-1 + call trav_rhs(coder,cblock,node,rhs,n) + call trav_lhs(coder,cblock,node,lhs,rhs) + coder%vtop=base + end subroutine trav_assign_define - ! Create extended tile variables - nvar_base=coder%top - nvars=0 - do i=1,nlist,2 - namelist=node_arg(list,i+1) - do j=1,node_numargs(namelist),2 - nvars=nvars+1 - call make_var(coder,cblock,namelist,node_arg(node_arg(namelist,j),1),var_is_shadowed) - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(expr_base+nvars)) - call code_val(coder,coder%vstack(nhd_base+(i+2)/2)) - call code_val(coder,coder%var(coder%par_base+lv_index)) - call code_val(coder,coder%var(coder%par_base+lv_here)) - call make_comm_sys_call(coder,cblock,node_arg(namelist,j),sym_nhd_var,4,1) - enddo + !======================================================== + ! Traverse multiple assignments, var/const definitions + !======================================================== + recursive subroutine trav_assign_define_list(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: assn,lhs,rhs + integer:: i,n,sym,base + base=coder%vtop + do i=1,node_numargs(node) + assn=node_arg(node,i) + lhs=node_arg(assn,1) + sym=node_sym(lhs) + n=node_numargs(lhs) + if(sym/=sym_define) n=n-1 + rhs=node_arg(assn,2) + call trav_rhs(coder,cblock,node,rhs,n) enddo - - ! Initialise extended tile variables - k=1 - do i=1,nlist,2 - namelist=node_arg(list,i+1) - do j=1,node_numargs(namelist),2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%var(nvar_base+k)) - call code_val(coder,coder%vstack(expr_base+k)) - call make_comm_sys_call(coder,cblock,node_arg(namelist,j),sym_set_nhd,2,0,assign=.true.) - k=k+1 - enddo + do i=node_numargs(node),1,-1 + assn=node_arg(node,i) + lhs=node_arg(assn,1) + rhs=node_arg(assn,2) + call trav_lhs(coder,cblock,node,lhs,rhs) enddo - - ! join extended tile variables in each nhd into a list for each nhd - join_base=coder%vtop - k=1 - do i=1,nlist,2 - namelist=node_arg(list,i+1) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call code_val(coder,coder%var(k+nvar_base)) - call make_sys_call(coder,cblock,node,sym_nhd_join,1,1,& - aflags=proc_run_shared+proc_run_always+call_ignore_rules+call_inline_when_compiling) - k=k+1 - do j=3,node_numargs(namelist),2 - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call code_val(coder,coder%var(k+nvar_base)) - call make_sys_call(coder,cblock,node,sym_nhd_join,2,1,& - aflags=proc_run_shared+proc_run_always+call_ignore_rules+call_inline_when_compiling) - k=k+1 + coder%vtop=base + end subroutine trav_assign_define_list + + !======================================================== + ! Traverse left hand side of assignment or definition + ! Computes these in *reverse* order assuming RHS has + ! stacked them one after the other. + !======================================================== + subroutine trav_lhs(coder,cblock,node,lhs,rhs) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,node,lhs,rhs + integer:: i,n,sym + type(pm_ptr):: rhs_val + n=node_numargs(lhs) + sym=node_sym(lhs) + select case(sym) + case(sym_var,sym_const) + do i=n-1,1,-1 + call trav_cast(coder,cblock,lhs,node_arg(lhs,n),sym) + call make_definition(coder,cblock,lhs,node_arg(lhs,i),& + merge(0,var_is_var,sym==sym_const)) enddo - enddo - - ! Send intersecting boundaries - do i=1,nlist/2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(join_base+i)) - call code_val(coder,coder%vstack(nhd_base+i)) - call code_val(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,node,sym_send_nhd,3,0,assign=.true.) - enddo - - call make_const(coder,cblock,node,coder%true) - call define_sys_var(coder,cblock,node,sym_in_interior,var_is_shadowed) - var=coder%top - - ! Check we are in an acceptable parallel context - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot have "nhd" statement outside of any parallel context') - elseif(coder%par_state==par_state_nhd) then - call code_error(coder,node,& - 'Cannot have "nhd" statement in the main body of another "nhd" statement') - elseif(coder%par_state>=par_state_cond) then - call code_error(coder,node,& - 'Cannot have "nhd" statement in a conditional context') - endif - save_par_state=coder%par_state - coder%par_state=par_state_nhd - - ! Get shape of chunks to iterate over - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call code_val(coder,coder%var(coder%par_base+lv_tile)) - call code_val(coder,coder%var(env_base)) - call make_sys_call(coder,cblock,node,sym_chunks,2,1,aflags=proc_run_shared+proc_run_always) - call define_sys_var(coder,cblock,node,sym_for,var_is_shadowed) - iter=call_start(coder,cblock,list,.true.) - - ! Run code block over chunk[0] -- interior of tile - call make_sys_var(coder,cblock,node,sym_subregion,var_is_shadowed) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - over_base=coder%top - call make_comm_call_args(coder,cblock,node) - call make_temp_var(coder,cblock,node) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_val(coder,coder%var(coder%par_base+lv_tile)) - call code_val(coder,coder%var(env_base)) - call code_val(coder,coder%var(iter+lv_idx)) - call code_val(coder,coder%var(env_base+1)) - call make_sys_call(coder,cblock,node,sym_get_chunk,4,1,aflags=proc_run_shared+proc_run_always) - call code_val(coder,coder%var(block_base)) - call make_comm_sys_call(coder,cblock,node_arg(node,5),sym_pm_over,2,1) - call make_do_over(coder,cblock,node,node,node_arg(node,5),over_base) - - call code_val(coder,coder%var(var)) - - ! RECV intersecting boundaries - do i=1,nlist/2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(join_base+i)) - call code_val(coder,coder%vstack(nhd_base+i)) - call code_val(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,node,sym_recv_nhd,3,0,assign=.true.) - enddo - - ! Sync messages - do i=1,nlist/2 - call code_val(coder,coder%vstack(join_base+i)) - call make_basic_sys_call(coder,cblock,node,sym_sync_messages,1,0,coder%par_depth,0) - enddo - - ! Bcast boundaries - do i=1,nlist/2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(join_base+i)) - call code_val(coder,coder%vstack(nhd_base+i)) - call code_val(coder,coder%var(env_base+1)) - call make_comm_sys_call(coder,cblock,node,sym_bcast_nhd,3,0,assign=.true.) - enddo - - call call_next(coder,cblock,list,iter,.true.) + case(sym_define) + if(node_sym(rhs)==sym_define) then + rhs_val=node_arg(rhs,1) + else + rhs_val=rhs + endif + do i=n,1,-1 + call trav_single_lhs(coder,cblock,lhs,node_arg(lhs,i),rhs_val) + enddo + end select + end subroutine trav_lhs - if(pm_is_compiling) then - call make_sys_var(coder,cblock,node,sym_while,& - var_is_shadowed) + !============================================================= + ! Traverse single element of the left hand side of assignment + ! or definition (simple "=", not var or const) + !============================================================= + subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,node,lhs,rhs + type(pm_ptr):: var + type(pm_ptr):: name + integer:: rsym + if(pm_fast_isname(lhs)) then + name=lhs + elseif(node_sym(lhs)==sym_name) then + name=node_arg(lhs,1) + elseif(node_sym(lhs)==sym_lt) then + call make_op_assignment_noalias(coder,cblock,lhs,node_arg(lhs,1),node_arg(lhs,2)) + return else - call code_null(coder) - endif - - ! Run code block over each edge chunk - cblock2=make_cblock(coder,cblock,node,sym_nhd) - call code_val(coder,coder%var(over_base)) - call make_comm_call_args(coder,cblock2,node) - call make_temp_var(coder,cblock2,node) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_val(coder,coder%var(coder%par_base+lv_tile)) - call code_val(coder,coder%var(env_base)) - call code_val(coder,coder%var(iter+lv_idx)) - call code_val(coder,coder%var(env_base+1)) - call make_sys_call(coder,cblock2,node,sym_get_chunk,4,1,aflags=proc_run_shared+proc_run_always) - call code_val(coder,coder%var(block_base)) - call make_comm_sys_call(coder,cblock2,node_arg(node,5),sym_pm_over,2,1) - call make_do_over(coder,cblock2,node,node,node_arg(node,5),over_base) - call call_next(coder,cblock2,list,iter,.true.) - call code_val(coder,coder%var(iter+lv_end)) - call close_cblock(coder,cblock2) - call make_sp_call(coder,cblock,node,sym_each,3,0) - - ! Clean up - coder%vtop=nhd_base - coder%par_state=save_par_state - - call pop_vars_to(coder,stmt_base) - contains - include 'fisnull.inc' - end subroutine trav_nhd_stmt - - - !************************************************** - ! PARALLEL STATEMENTS - !************************************************** - - !======================================================== - ! Traverse a for statement - !======================================================== - recursive subroutine trav_for_stmt(coder,cblock,listp,list,base,stmt) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,listp,list,stmt - integer,intent(in):: base - type(pm_ptr):: var,vlist - type(pm_ptr):: cblock2,cblock3,cblock4 - type(pm_ptr):: cblock_main,cblock_pre,cblock_post - integer:: i,j,k,n,lbase,vbase - integer:: nlist,iter,iter2,sym,rbase,wbase,name,flags,sindex,sbase - integer:: slot1,slot2,outmode - integer(pm_p)::flag - type(pm_ptr):: vlhs,procs,sig,xvar,p - integer:: save_par_base,save_over_base,save_par_state,save_run_mode - type(pm_ptr):: save_loop_cblock - logical:: iscomm,outer,is_conc - - sym=node_sym(stmt) - is_conc=node_get_num(stmt,node_args+2)==sym_conc - rbase=coder%vtop - wbase=coder%wtop - - call trav_iter(coder,cblock,list,sym_hash,lbase,vbase,nlist) - - save_par_base=coder%par_base - save_over_base=coder%over_base - save_loop_cblock=coder%loop_cblock - save_par_state=coder%par_state - save_run_mode=coder%run_mode - - ! Start parallel loop call - iter=code_par_scope_start(coder,cblock,stmt,coder%var(coder%top),& - node_arg(stmt,1),& - cblock_main,cblock_pre,sym_for_stmt,.false.) - - slot1=coder%index - - ! Hide any where clauses (may need them later) - if(base>=0) then - call hide_vars(coder,base+1,coder%top) - endif - - sindex=iter+lv_here - - ! Create array/domain element variables for this iteration - sbase=coder%top - do i=1,nlist,2 - var=node_arg(list,i) - if(node_sym(var)==sym_mult) then - call make_var(coder,cblock_main,list,& - node_arg(var,1),var_is_var) - else - call make_var(coder,cblock_main,list,& - var,var_is_var) - endif - enddo - - ! Get array/domain elements for this iteration - do i=1,nlist/2 - if(node_sym(node_arg(list,i*2-1))==sym_mult) then - call code_val(coder,coder%var(sbase+i)) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call code_val(coder,coder%vstack(lbase+i)) - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - aflags=call_ignore_rules+proc_run_shared+proc_run_always) - else - call make_basic_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - coder%par_depth-1,call_ignore_rules) - endif - else - call code_val(coder,coder%var(sbase+i)) - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_here)) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_index)) - call code_val(coder,coder%var(sindex)) - call make_comm_sys_call(coder,cblock_main,list,sym_for_get_element,3,1) - call code_val(coder,coder%var(sbase+i)) - call make_sp_call(coder,cblock_main,list,sym_coherent,1,0) - endif - enddo - - ! Main body - coder%par_state=par_state_for - coder%run_mode=sym_complete - call trav_open_stmt_list(coder,cblock_main,stmt,node_arg(stmt,4)) - - if(base>=0) call reveal_vars(coder,base,vbase) - - ! Export variables that have changed - do i=1,nlist/2 - var=coder%var(sbase+i) - if(cnode_flags_set(var,var_flags,var_is_changed)) then - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_here)) - outmode=trav_ref(coder,cblock_main,node_arg(list,i*2),& - node_arg(list,i*2),ref_ignores_rules) - call code_val(coder,var) - call code_val(coder,coder%var(iter+lv_index)) - call code_val(coder,coder%var(sindex)) - call make_comm_sys_call(coder,cblock_main,stmt,& - sym_for_set_element,4,0,assign=.true.,& - aflags=call_is_comm+call_inline_when_compiling) - endif - enddo - slot2=coder%index - - ! Complete parallel for call - call code_par_scope_end(coder,iter,list,cblock,& - cblock_main,cblock_pre,save_par_base,slot1,slot2,is_conc,.false.) - - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%loop_cblock=save_loop_cblock - coder%par_state=save_par_state - coder%run_mode=save_run_mode - - if(base>=0) call hide_vars(coder,base,sbase) - - ! Clean up - coder%vtop=rbase - - call pop_vars_to(coder,vbase) - - contains - include 'fisnull.inc' - include 'fisname.inc' - include 'fname.inc' - include 'ftiny.inc' - end subroutine trav_for_stmt - - - !======================================================== - ! Traverse par { } - !======================================================== - recursive subroutine trav_par_stmt(coder,cblock,pnode,node) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - type(pm_ptr):: let,clause,cblock_main,cblock_pre,cblock_post - type(pm_ptr):: vlist,save_loop_cblock - integer:: i,j,k,iter,istart,vstart,base,rbase,m - integer:: save_par_base,save_over_base,save_par_state - integer:: slot1,slot2 - integer:: name,flags - - vstart=coder%vtop - save_loop_cblock=coder%loop_cblock - save_par_base=coder%par_base - save_over_base=coder%over_base - save_par_state=coder%par_state - - base=coder%top - - if(node_numargs(node)==4) then - call code_error(coder,node,'"par" statement has only one branch') - coder%vtop=vstart - return - endif - - ! Variable sym_for - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_long_const(coder,cblock,node,& - int((node_numargs(node)-2)/2,pm_ln)) - call make_sys_call(coder,cblock,node,sym_array,1,1) - call define_sys_var(coder,cblock,node,sym_for,var_is_shadowed) - - ! Partition the domain across processors - iter=code_par_scope_start(coder,cblock,node,coder%var(coder%top),& - node_arg(node,1),cblock_main,cblock_pre,sym_also,.false.) - - slot1=coder%index - - do i=3,node_numargs(node),2 - call make_long_const(coder,cblock_main,node,int((i-2)/2,pm_ln)) - call make_definition(coder,cblock_main,node,node_arg(node,i),0) - enddo - - coder%par_state=par_state_for - - ! statements before any branch - call trav_open_stmt_list(coder,cblock_main,node,node_arg(node,2)) - - coder%par_state=par_state_par - - ! branches - call branch(cblock_main,3) - - slot2=coder%index - - ! Build parallel statement call - call code_par_scope_end(coder,iter,node,cblock,cblock_main,& - cblock_pre,& - save_par_base,slot1,slot2,.false.,.false.) - - coder%vtop=vstart - coder%loop_cblock=save_loop_cblock - coder%par_base=save_par_base - coder%over_base=save_over_base - call pop_vars_to(coder,base) - contains - include 'fisnull.inc' - include 'ftiny.inc' - - recursive subroutine branch(cblock,i) - type(pm_ptr),intent(in):: cblock - integer,intent(in):: i - type(pm_ptr):: cblock4,cblock5 - type(pm_ptr):: prc_test_var - integer:: n - - ! Is this branch running on this processor? - call make_temp_var(coder,cblock,node) - prc_test_var=top_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_long_const(coder,cblock,node,int((i-2)/2,pm_ln)) - call make_sys_call(coder,cblock,node,sym_tuple,1,1) - call code_val(coder,coder%var(iter+lv_here)) - call make_sys_call(coder,cblock,node,sym_eq,2,1) - - if(i/=cnode_numargs(node)-1) then - ! If statment (if running_here then ... endif) - coder%if_scope=push_if_scope(coder) - call code_val(coder,prc_test_var) - cblock4=make_cblock(coder,cblock,node,sym_also) - ! task clause - call trav_open_stmt_list(coder,cblock4,node,node_arg(node,i+1)) - call close_cblock(coder,cblock4) - cblock5=make_cblock(coder,cblock,node,sym_also) - ! remaining task clauses - call branch(cblock5,i+2) - call close_cblock(coder,cblock5) - n=get_if_scope(coder) - call make_sp_call(coder,cblock,node,sym_if,3+n,0) - call pop_if_scope(coder) - else - ! task clause - call trav_open_stmt_list(coder,cblock,node,node_arg(node,i+1)) - endif - - end subroutine branch - - end subroutine trav_par_stmt - - !======================================================== - ! traverse { : } expression - !======================================================== - recursive subroutine trav_par_expr(coder,cblock,node) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer:: iter,slot1,slot2,lbase,vbase,nlist,base - integer:: sbase,i,save_par_base,save_over_base,save_par_state - type(pm_ptr):: rvar,var,cblock_main,cblock_pre,list,save_loop_cblock - - list=node_arg(node,2) -!!$ if(.not.pm_is_compiling) call make_temp_var(coder,cblock,node) - call make_temp_var(coder,cblock,node) - base=coder%vtop - rvar=top_code(coder) - - call trav_iter(coder,cblock,list,sym_hash,lbase,vbase,nlist) - - save_par_base=coder%par_base - save_loop_cblock=coder%loop_cblock - save_par_state=coder%par_state - save_over_base=coder%over_base - - iter=code_par_scope_start(coder,cblock,node,coder%var(coder%top),pm_null_obj,& - cblock_main,cblock_pre,sym_for_stmt,.false.) - slot1=coder%index - - ! Get array/domain elements - sbase=coder%top - do i=1,nlist,2 - var=node_arg(list,i) - if(node_sym(var)==sym_mult) var=node_arg(var,1) - call make_var(coder,cblock_main,node,& - var,0) - enddo - do i=1,nlist/2 - if(node_sym(node_arg(list,i*2-1))==sym_mult) then - call code_val(coder,coder%var(sbase+i)) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call code_val(coder,coder%vstack(lbase+i)) - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - aflags=call_ignore_rules+proc_run_shared+proc_run_always) - else - call make_basic_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - coder%par_depth-1,call_ignore_rules) - endif - else - call code_val(coder,coder%var(sbase+i)) - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_here)) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_index)) - call code_val(coder,coder%var(iter+lv_index)) - call make_comm_sys_call(coder,cblock_main,node,sym_for_get_element,3,1) - endif - enddo - coder%par_state=par_state_for - call code_val(coder,rvar) - if(.not.pm_is_compiling) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - endif - call make_comm_call_args(coder,cblock,node) - if(pm_is_compiling) then - call make_temp_var(coder,cblock_main,node) - call dup_code(coder) - endif - - call trav_expr(coder,cblock_main,node,node_arg(node,1)) - - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,node,sym_dup,1,1,aflags=call_ignore_rules) - endif - call dup_code(coder) - call code_num(coder,sym_chan) - call make_basic_sp_call(coder,cblock_main,node,sym_set_mode,2,0,coder%par_depth) - call make_comm_sys_call(coder,cblock_main,node,sym_make_array,1,1) - if(.not.pm_is_compiling) then - call make_basic_sp_call(coder,cblock_main,node,sym_export_as_new,& - 1,1,coder%par_depth) - endif - - slot2=coder%index - call code_par_scope_end(coder,iter,node,cblock,cblock_main,& - cblock_pre,save_par_base,slot1,slot2,.true.,.false.) - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%par_state=save_par_state - coder%loop_cblock=save_loop_cblock - call pop_vars_to(coder,vbase) -!!$ if(.not.pm_is_compiling) then -!!$ call make_basic_sys_call(coder,cblock,node,sym_correct_array,1,1,coder%loop_depth,0) -!!$ endif - coder%vtop=base - end subroutine trav_par_expr - - - !======================================================== - ! Over statement - !======================================================== - recursive subroutine trav_over_stmt(coder,cblock,pnode,node) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer:: base,save_par_state,save_over_base - integer:: save_run_mode,save_run_flags - type(pm_ptr):: p,stmt_list,attr,cblock2 - logical:: ok - - if(coder%par_state==par_state_outer)then - call code_error(coder,node,& - 'Cannot have "over" statement outside of a parallel context') - elseif(coder%par_state/=par_state_for.and.coder%par_state/=par_state_over.and.& - coder%par_state/=par_state_nhd) then - if(coder%par_state==par_state_any) then - call code_error(coder,node,& - 'Cannot have "over" statement in a (non-"invar") "any" statement') - elseif(coder%par_state==par_state_par) then - call code_error(coder,node,& - 'Cannot have "over" statement in "par task"') - else - call code_error(coder,node,& - 'Cannot have "over" statement in a conditional context') - endif - endif - save_par_state=coder%par_state - coder%par_state=par_state_for - call make_sys_var(coder,cblock,node,sym_subregion,var_is_shadowed) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - base=coder%top - call hide_vars(coder,base,base) - call make_comm_call_args(coder,cblock,node) - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - coder%run_mode=sym_shared - coder%run_flags=proc_run_shared+proc_run_always - call trav_xexpr(coder,cblock,node,node_arg(node,1)) - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - attr=node_arg(node,2) - call trav_expr(coder,cblock,node,node_arg(attr,1)) - call make_comm_sys_call(coder,cblock,node,sym_make_over,2,1) - call reveal_vars(coder,base,base) - stmt_list=node_arg(node,3) - call make_do_over(coder,cblock,pnode,node,stmt_list,base) - coder%par_state=save_par_state - contains - include 'fisnull.inc' - end subroutine trav_over_stmt - - !================================= - ! Body of an over statement - ! (also used by nhd statements) - !================================= - recursive subroutine make_do_over(coder,cblock,pnode,node,statlist,base) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node,statlist - integer,intent(in):: base - integer:: save_par_state,save_over_base - type(pm_ptr):: cblock2 - - save_par_state=coder%par_state - save_over_base=coder%over_base - - coder%over_base=base - if(coder%par_state/=par_state_nhd) coder%par_state=par_state_over - if(pm_is_compiling) then - cblock2=make_cblock(coder,cblock,node,sym_using) - call make_sys_var(coder,cblock2,node,sym_nested_loop,var_is_shadowed) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_val(coder,coder%var(base)) - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call make_basic_sys_call(coder,cblock2,node,sym_do_over,2,1,& - coder%par_depth-1,call_inline_when_compiling+proc_run_shared+proc_run_always) - call make_basic_sys_call(coder,cblock2,node,sym_nested_loop,1,0,& - coder%par_depth-1,call_inline_when_compiling) - call close_cblock(coder,cblock2) - call trav_stmt_list(coder,cblock,node,statlist,sym_over) - call make_sp_call(coder,cblock,node,sym_over,2,0) - else - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%var(base)) - call make_comm_sys_call(coder,cblock,node,sym_do_over,1,1) - call trav_stmt_list(coder,cblock,node,statlist,sym_over) - call code_null(coder) - call make_sp_call(coder,cblock,node,sym_if,3,0) - endif - coder%par_state=save_par_state - coder%over_base=save_over_base - end subroutine make_do_over - - !======================================================== - ! Start a new parallel scope - ! - leaves quite a bit on the vstack - ! - this needs to be there until scope closes - ! (protection against GC) - !======================================================== - function code_par_scope_start(coder,cblock,stmt,var,using,& - cblock_main,cblock_pre,sym,is_tile) result(iter) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,stmt,var,using - type(pm_ptr),intent(out):: cblock_main,cblock_pre - integer,intent(in):: sym - logical,intent(in):: is_tile - integer:: iter - integer:: n,i,vbase - type(pm_ptr):: loop_cblock - - call make_sys_var(coder,cblock,stmt,sym_proc,var_is_shadowed) - call make_sys_var(coder,cblock,stmt,sym_region,var_is_shadowed) - call make_sys_var(coder,cblock,stmt,sym_in,var_is_shadowed) - iter=coder%top - call make_sys_var(coder,cblock,stmt,sym_pling,var_is_shadowed) - call make_sys_var(coder,cblock,stmt,sym_hash,var_is_shadowed) - call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) - !@call cnode_set_num(coder%var(iter+lv_numz),var_par_depth,coder%par_depth+1) - - ! sym_in,region,schedule := partition(sym_proc,sym_for,using...) - vbase=coder%vtop - cblock_pre=make_cblock(coder,cblock,stmt,sym_using) - call make_temp_var(coder,cblock_pre,stmt) - call make_temp_var(coder,cblock_pre,stmt) - call make_temp_var(coder,cblock_pre,stmt) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%var(iter+lv_prc)) - call code_val(coder,var) - - if(.not.pm_fast_isnull(using)) then - n=node_numargs(using) - do i=1,n - call trav_expr(coder,cblock_pre,using,node_arg(using,i)) - enddo - do i=n+1,num_using_clauses - call make_const(coder,cblock,using,pm_null_obj,int(pm_null)) - enddo - call make_sys_call(coder,cblock_pre,using,& - sym_partition,& - 2+num_using_clauses,3) - else - call make_sys_call(coder,cblock_pre,stmt,sym_partition,2,3) - endif - - ! Init variables: tile, region - call code_val(coder,coder%vstack(vbase+2)) - call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_tile)) - call code_val(coder,coder%vstack(vbase+3)) - call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_distr)) - - ! Variable sym_pling set to number of elements in domain - call make_temp_var(coder,cblock_pre,stmt) - call dup_code(coder) - call code_val(coder,coder%var(iter+lv_distr)) - call make_sys_call(coder,cblock_pre,stmt,sym_num_elements,1,1) - call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_num)) - - ! Alias the region variable - call push_var(coder,sym_region,coder%var(iter+lv_distr)) - - ! Create the subregion variable - call make_sys_var(coder,cblock,stmt,sym_subregion,var_is_shadowed) - call code_val(coder,coder%vstack(vbase+4)) - call init_var(coder,cblock_pre,stmt,coder%var(coder%top)) - coder%over_base=coder%top - - ! Outer code block (contains imports/exports) - loop_cblock=make_cblock(coder,cblock,stmt,sym) - call push_par_scope(coder,loop_cblock) - coder%loop_cblock=loop_cblock - coder%par_base=iter - - ! Inner block - contains statements - cblock_main=make_cblock(coder,loop_cblock,stmt,sym_for) - - if(.not.is_tile) then - - ! Variable here_in_tile set to local iteration indices in this thread - call make_sys_var(coder,cblock_main,stmt,sym_here_in_tile,var_is_shadowed) - if(pm_is_compiling) then - call make_temp_var(coder,cblock_main,stmt) - call var_set_par_depth(coder,coder%var(iter+lv_index),coder%par_depth-1) - call dup_code(coder) - endif - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(iter+lv_numz)) - call code_val(coder,coder%var(coder%over_base)) - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,stmt,& - sym_generate,3,1,& - call_inline_when_compiling+proc_run_shared+call_ignore_rules+proc_run_always) - call make_basic_sys_call(coder,cblock_main,stmt,& - sym_generate,1,1,coder%par_depth-1,0) - else - call make_basic_sys_call(coder,cblock_main,stmt,& - sym_generate,3,1,coder%par_depth-1,& - call_inline_when_compiling) - endif - call var_set_par_depth(coder,coder%var(iter+lv_index),coder%par_depth) - - ! Get element [here_in_tile] from tile to yield here - call make_sys_var(coder,cblock_main,stmt,sym_here,& - var_is_shadowed) - call code_val(coder,coder%var(iter+lv_tile)) - call code_val(coder,coder%var(iter+lv_index)) - call make_sys_call(coder,cblock_main,stmt,sym_get_element,2,1) - - if(coder%top/=iter+7) then - write(*,*) '===========================' - do i=iter,coder%top - write(*,*) pm_name_as_string(coder%context,coder%stack(i)) - enddo - write(*,*) coder%top,iter,coder%top-iter - call pm_panic('push_par_scope') - endif - - endif - - contains - - include 'fname.inc' - include 'fisnull.inc' - - end function code_par_scope_start - - !============================================================================ - ! Complete current parallel scope - ! - iter, cblock_main -- as returned by code_par_scope_start - ! - cblock_post -- must be allocated as a code block if not "conc" - ! - old_par_base -- no longer used - ! - slot1,slot2 -- range of indices (coder%index) covered by this statement - !============================================================================ - subroutine code_par_scope_end(coder,iter,node,& - cblock,cblock_main,cblock_pre,old_par_base,slot1,slot2,is_conc,is_tile) - type(code_state),intent(inout):: coder - integer,intent(in):: iter - type(pm_ptr),intent(in):: node,cblock,cblock_main,cblock_pre - integer,intent(in):: old_par_base,slot1,slot2 - logical,intent(in):: is_conc,is_tile - type(pm_ptr):: p - - ! Inner call to for - call close_cblock(coder,cblock_main) - call code_val(coder,cblock_main) - call make_sp_call(coder,coder%loop_cblock,node,sym_for,1,0) - - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call make_sys_call(coder,coder%loop_cblock,node,sym_pop_node,1,0,& - aflags=call_ignore_rules+merge(0,proc_run_shared+proc_run_always,pm_is_compiling)) - - ! Close loop cblock - call close_cblock(coder,coder%loop_cblock) - call pop_par_scope(coder,coder%loop_cblock,node) - - ! Close cblock_pre - call close_cblock(coder,cblock_pre) - - ! Build par-loop call - ! #, sym_prc = main_block,pre_block,post_block, $, is_conc, slots - call code_val(coder,coder%var(iter+lv_numz)) - call code_val(coder,coder%var(iter+lv_prc)) - - call code_val(coder,coder%loop_cblock) - call code_val(coder,cblock_pre) - call code_val(coder,pm_null_obj) !!!@ Legacy - need to remove - call code_val(coder,coder%var(iter+lv_num)) - if(is_conc) then - call make_const(coder,cblock,node,pm_null_obj,int(pm_null)) - else - call make_const(coder,cblock,node,coder%true) - endif - - ! Two-integer entry giving range of slots used by statement - p=pm_fast_newnc(coder%context,pm_int,2) - call make_const(coder,cblock,node,p) - p%data%i(p%offset)=slot1 - p%data%i(p%offset+1)=slot2 - - ! Code parallel statement call - call make_sp_call(coder,cblock,node,sym_for_stmt,6,2) - - ! Adjust par_depth of result - call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) - - contains - include 'fnewnc.inc' - include 'fisnull.inc' - end subroutine code_par_scope_end - - !======================================================== - ! Push a parallel scope level - !======================================================== - subroutine push_par_scope(coder,cblock) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock - integer:: depth, kk - depth=coder%par_depth - if(depth==max_par_depth) then - call pm_panic('Program too complex (nested parallel scopes)') - endif - depth=depth+1 - coder%import_cblock(depth)=cblock - coder%par_depth=depth - end subroutine push_par_scope - - !======================================================== - ! Pop down parallel scope level - !======================================================== - subroutine pop_par_scope(coder,cblock,node) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer:: depth - coder%par_depth=coder%par_depth-1 - contains - include 'fisnull.inc' - end subroutine pop_par_scope - - !==================================================================== - ! Import argument list for a call - ! Arguments must be on vstack (nret, nkey, narg items respectively) - !==================================================================== - subroutine import_args(coder,cblock,node,narg,nret,nkey,amps,flags,base) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,amps - integer,intent(in)::narg,nret,nkey,flags - integer,intent(out):: base - integer:: depth - integer:: i,j,top,totsize,nextra - logical:: isamp,export,iscomm - type(pm_ptr):: amp - - top=coder%vtop - - iscomm=iand(flags,call_is_comm)/=0 - if(iscomm) then - depth=coder%par_depth-1 - export=.false. - elseif(iand(flags,proc_run_shared+proc_run_local)/=0) then - depth=coder%par_depth-1 - export=.true. - else - depth=coder%par_depth - export=.false. - endif - - if(pm_fast_isnull(amps)) then - do i=top+1-narg-nkey,top - call import_arg(i,.false.) - enddo - else - amp=pm_name_val(coder%context,int(amps%offset)) - do i=top+1-narg-nkey,top-narg - call import_arg(i,.false.) - enddo - j=0 - do i=top+1-narg,top - isamp=amp%data%i(amp%offset+j)==i-(top-narg) - if(isamp.and.jdepth.and.export) then - if(cnode_flags_set(var,var_flags,var_is_imported)) then - nvar=cnode_get(var,var_extra_info) - else - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call cnode_set_flags(top_code(coder),var_flags,var_is_imported) - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,node,sym_export_as_new,& - 1,1,coder%par_depth) - call var_set_par_depth(coder,top_code(coder),depth) - nvar=pop_code(coder) - endif - else - nvar=var - endif - coder%vstack(index)=nvar - end subroutine import_arg - - end subroutine import_args - - !======================================================== - ! Import a variable into a parallel scope at given depth - !======================================================== - function import_to_par_scope(coder,cblock,node,var,depth) result(ivar) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,var - integer,intent(in):: depth - type(pm_ptr):: ivar - integer:: i,j,vdepth,vcdepth,name,base - ivar=var - if(pm_fast_vkind(var)/=pm_pointer) return - if(cnode_get_kind(var)/=cnode_is_var) return - if(cnode_flags_set(var,var_flags,var_is_no_import_export)) then - ivar=cnode_get(var,var_extra_info) - return - endif - vdepth=par_depth(coder,var) - vcdepth=cnode_get_num(var,var_create_depth)+coder%proc_par_depth - if(vcdepth>vdepth) then - if(pm_debug_checks) then - if(depth/=vdepth+1) call pm_panic('import temp gone wrong') - endif - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call code_val(coder,ivar) - call make_basic_sp_call(coder,cblock,node,sym_import_val,1,1,depth) - ivar=pop_code(coder) - elseif(vdepthn1) exit p1=coder%vstack(base1+i) enddo - call make_sys_call(coder,cblock,node,sym_combine_indices,& + call make_sys_call_rtn(coder,cblock,node,sym_combine_indices,& coder%vtop-vbase,1) endif endif @@ -3539,8 +2447,6 @@ subroutine match_ref_pattern(coder,cblock,node,base1,base2,idx1,idx2,list,test) if(j<=n2) then p2=coder%vstack(base2+j) if(.not.pm_fast_isname(p2)) then - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) vbase=coder%vtop-1 do while(.not.pm_fast_isname(p2)) has_dollar=trav_index_list(coder,cblock,node_arg(p2,2),.true.) @@ -3548,7 +2454,7 @@ subroutine match_ref_pattern(coder,cblock,node,base1,base2,idx1,idx2,list,test) if(j>n2) exit p2=coder%vstack(base2+j) enddo - call make_sys_call(coder,cblock,node,sym_combine_indices,& + call make_sys_call_rtn(coder,cblock,node,sym_combine_indices,& coder%vtop-vbase,1) endif endif @@ -3650,10 +2556,6 @@ recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) has_underscore_error=.false. flags=0 n=node_numargs(node) - if(n>1.or.node_sym(node)==sym_dotdotdot) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - endif save_subs_index=coder%subs_index which=0 replicated=.false. @@ -3688,7 +2590,7 @@ recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) 'Cannot use "$" without ".dimension" in subscript with more than one argument') endif if(n>1.or.node_sym(node)==sym_dotdotdot) then - call make_sys_call(coder,cblock,node,sym_tuple,n,1,& + call make_sys_call_rtn(coder,cblock,node,sym_tuple,n,1,& aflags=flags) endif if(max_idx>0) then @@ -3696,13 +2598,9 @@ recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) call code_error(coder,node,'Cannot have "$" index outside of any parallel context') endif coder%temp2=pop_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call code_val(coder,coder%temp2) coder%temp2=pm_null_obj if(max_idx>1.and.all(which(2:max_idx)>0)) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) do i=2,max_idx if(which(i)>0) then call make_static_long_const(coder,cblock,node,int(which(i),pm_ln)) @@ -3710,10 +2608,10 @@ recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) call make_const(coder,cblock,node,pm_null_obj,int(pm_null)) endif end do - call make_sys_call(coder,cblock,node,sym_tuple,max_idx-1,1) - call make_sys_call(coder,cblock,node,sym_make_dtuple,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_tuple,max_idx-1,1) + call make_sys_call_rtn(coder,cblock,node,sym_make_dtuple,2,1) else - call make_sys_call(coder,cblock,node,sym_make_dtuple,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_make_dtuple,1,1) endif endif coder%subs_index=save_subs_index @@ -3806,7 +2704,7 @@ subroutine make_var_assignment(coder,cblock,node,var,aflags) call make_assign_call(coder,cblock,node,sym_assignment,2,0,aflags=flags) endif call cnode_set_flags(v,var_flags,var_is_changed) - call update_change_lists(coder,var) + call update_change_lists(coder,var,.true.) end subroutine make_var_assignment @@ -3891,18 +2789,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) case(sym_arg,sym_name,sym_use) call trav_name(coder,cblock,node,sym,node_arg(node,1)) case(sym_proc) - if(node_numargs(node)==1) then - call proc_const(coder,cblock,node,node_arg(node,1)) - else - p=find_imported_decl(coder,node,& - node_arg(node,1),node_arg(node,2),modl_proc) - if(pm_fast_isnull(p)) then - call make_temp_var(coder,cblock,node) - else - call proc_const_from_decl(coder,cblock,node,p) - endif - endif - return + call proc_const(coder,cblock,pnode,node) case(sym_param) if(node_numargs(node)==2) then p=find_param(coder,cblock,node,node_arg(node,1),& @@ -3942,13 +2829,11 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) endif return case(sym_fix) - call make_temp_var(coder,cblock,node) - call dup_code(coder) save_fixed=coder%fixed coder%fixed=.true. call trav_expr(coder,cblock,node,node_arg(node,1)) coder%fixed=save_fixed - call make_sp_call(coder,cblock,node,sym_dash,1,1) + call make_sp_call_rtn(coder,cblock,node,sym_dash,1,1) case(sym_present) p=node_arg(node,1) i=p%offset @@ -3959,30 +2844,34 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) else q=coder%var(i) if(cnode_flags_set(q,var_flags,var_is_key)) then - call code_val(coder,coder%var(i+1)) + call code_val(coder,cnode_get(q,var_extra_info)) + call make_sp_call_rtn(coder,cblock,node,sym_present,1,1) else call code_error(coder,node,& 'Not a keyword argument in "present": ',p) call make_temp_var(coder,cblock,node) endif endif - case(first_operator:last_operator) - call make_temp_var(coder,cblock,node) - call dup_code(coder) + case(first_operator:last_operator) do i=1,node_numargs(node) call trav_expr(coder,cblock,& node,node_arg(node,i)) enddo - call make_sys_call(coder,cblock,node,& + call make_sys_call_rtn(coder,cblock,node,& sym,node_numargs(node),1) + case(sym_damp) + do i=1,node_numargs(node) + call trav_expr(coder,cblock,& + node,node_arg(node,i)) + enddo + call make_sys_call_rtn(coder,cblock,node,& + sym_list,node_numargs(node),1) case(sym_if_expr) - call make_temp_var(coder,cblock,node) - call dup_code(coder) do i=1,node_numargs(node) call trav_expr(coder,cblock,& node,node_arg(node,i)) enddo - call make_sys_call(coder,cblock,node,& + call make_sys_call_rtn(coder,cblock,node,& sym,node_numargs(node),1) case(sym_switch_expr) n=node_numargs(node) @@ -4016,38 +2905,27 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) enddo case(sym_uhash,sym_ustar) if(coder%par_state>par_state_outer) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_comm_call_args(coder,cblock,pnode) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_comm_sys_call(coder,cblock,node,& + call make_comm_sys_call_rtn(coder,cblock,node,& merge(sym_hash,sym_mult,sym==sym_uhash),1,1) else - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call(coder,cblock,node,& + call make_sys_call_rtn(coder,cblock,node,& merge(sym_hash,sym_mult,sym==sym_uhash),1,1) endif case(sym_lt) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call(coder,cblock,node,sym_gt,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_gt,2,1) case(sym_le) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call(coder,cblock,node,sym_ge,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_ge,2,1) case(sym_pm_dref:sym_pm_ref) - call make_temp_var(coder,cblock,node) - call dup_code(coder) do i=1,node_numargs(node) call trav_expr(coder,cblock,node,node_arg(node,i)) enddo - call make_sp_call(coder,cblock,node,sym,node_numargs(node),1) + call make_sp_call_rtn(coder,cblock,node,sym,node_numargs(node),1) case(sym_caret) if(node_numargs(node)==1) then outmode=trav_ref(coder,cblock,pnode,node,0) @@ -4063,45 +2941,37 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) var_is_shadowed+var_is_no_import_export,pop_code(coder)) endif case(sym_dcaret) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sp_call(coder,cblock,node,sym_dcaret,1,1) + call make_sp_call_rtn(coder,cblock,node,sym_dcaret,1,1) case(sym_dot) - call make_temp_var(coder,cblock,node) - call dup_code(coder) if(node_sym(node_arg(node,1))==sym_name) then call trav_expr(coder,cblock,node,node_arg(node,1)) call make_const(coder,cblock,node,node_arg(node,2)) - call make_sp_call(coder,cblock,node,sym_dot,2,1) + call make_sp_call_rtn(coder,cblock,node,sym_dot,2,1) else outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) if(coder%par_state>par_state_outer) then p=pop_code(coder) - call make_comm_call_args(coder,cblock,node) call code_val(coder,p) call make_static_bool_const(coder,cblock,node,iand(outmode,ref_has_at)/=0) - call make_comm_sys_call(coder,cblock,node,sym_get_ref,2,1) + call make_comm_sys_call_rtn(coder,cblock,node,sym_get_ref,2,1) call check_par_context(coder,cblock,node,.true.) else - call make_sys_call(coder,cblock,node,sym_get_val_ref,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_get_val_ref,1,1) endif endif case(sym_get_dot_ref) outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) case(sym_get_dot,sym_sub,sym_dot_sub) - call make_temp_var(coder,cblock,node) - call dup_code(coder) outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) if(coder%par_state>par_state_outer) then p=pop_code(coder) - call make_comm_call_args(coder,cblock,node) call code_val(coder,p) call make_static_bool_const(coder,cblock,node,iand(outmode,ref_has_at)/=0) - call make_comm_sys_call(coder,cblock,node,sym_get_ref,2,1) + call make_comm_sys_call_rtn(coder,cblock,node,sym_get_ref,2,1) call check_par_context(coder,cblock,node,.true.) else - call make_sys_call(coder,cblock,node,sym_get_val_ref,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_get_val_ref,1,1) endif case(sym_at) outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) @@ -4110,42 +2980,29 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call dup_code(coder) call trav_call(coder,cblock,pnode,node,1,.false.) case(sym_pval,sym_pval_as) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) call trav_expr(coder,cblock,node,node_arg(node,2)) - call swap_code(coder) - call make_sp_call(coder,cblock,node,sym,2,1) + call trav_expr(coder,cblock,node,node_arg(node,1)) + call make_sp_call_rtn(coder,cblock,node,sym,2,1) case(sym_type_val) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_type_constraint(coder,node,node_arg(node,1)) call make_const(coder,cblock,node,& pm_fast_tinyint(coder%context,pop_word(coder))) - call make_sp_call(coder,cblock,node,sym_type_val,1,1) + call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) case(sym_array_former,sym_matrix_former) i=node_get_num(node,node_args+2) - if(sym==sym_matrix_former) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - endif - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call array_span(node_get_num(node,node_args+3),node_get_num(node,node_args+1)) if(i/=1) then call array_span(node_get_num(node,node_args+4),i) - call make_sys_call(coder,cblock,node,sym_array,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_array,2,1) else - call make_sys_call(coder,cblock,node,sym_array,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_array,1,1) endif list=node_arg(node,1) call trav_expr(coder,cblock,list,node_arg(list,1)) call swap_code(coder) - call make_sys_call(coder,cblock,list,sym_do_dim,2,1) + call make_sys_call_rtn(coder,cblock,list,sym_do_dim,2,1) if(sym==sym_matrix_former) then - call make_sys_call(coder,cblock,node,sym_matrix_former,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_matrix_former,1,1) endif do i=2,node_numargs(list) call dup_code(coder) @@ -4185,15 +3042,13 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) sym_make_dollar,2,1) case(sym_for) - call trav_par_expr(coder,cblock,node) +!!$ call trav_par_expr(coder,cblock,node) case(sym_mode,sym_always) call trav_mode_stmt(coder,cblock,node,sym,.true.) case(sym_cast) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,1)) call trav_expr(coder,cblock,node,node_arg(node,2)) - call make_sp_call(coder,cblock,node,sym_cast,2,1) + call make_sp_call_rtn(coder,cblock,node,sym_cast,2,1) case(sym_number,sym_string) if(coder%fixed) then p=node_arg(node,1) @@ -4229,11 +3084,9 @@ end subroutine name_const subroutine range_const(p,n) type(pm_ptr):: p integer:: n - call make_temp_var(coder,cblock,p) - call dup_code(coder) call make_long_const(coder,cblock,p,0_pm_ln) call make_long_const(coder,cblock,p,int(n-1,pm_ln)) - call make_sys_call(coder,cblock,p,sym_dotdot,2,1) + call make_sys_call_rtn(coder,cblock,p,sym_dotdot,2,1) end subroutine range_const subroutine array_span(low,n) @@ -4242,13 +3095,11 @@ subroutine array_span(low,n) call make_long_const(coder,cblock,node,& int(n,pm_ln)) else - call make_temp_var(coder,cblock,node) - call dup_code(coder) call make_long_const(coder,cblock,node,& int(low,pm_ln)) call make_long_const(coder,cblock,node,& int(low+n-1,pm_ln)) - call make_sys_call(coder,cblock,node,sym_dotdot,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_dotdot,2,1) endif end subroutine array_span @@ -4269,14 +3120,12 @@ subroutine trav_name(coder,cblock,node,sym,name) p=find_imported_decl(coder,node,& name,node_arg(node,2),& modl_proc) - if(pm_fast_isnull(p)) then ! Note find_imported decl gives own error messages call make_var(coder,cblock,node,name,0) else call proc_const_from_decl(coder,cblock,node,p) endif - else call code_val(coder,p) endif @@ -4302,10 +3151,8 @@ subroutine trav_name(coder,cblock,node,sym,name) 'Cannot access "sync" left-hand-side variable in right-hand-side expression') endif if(cnode_flags_set(p,var_flags,var_is_ref)) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) call code_val(coder,p) - call make_sys_call(coder,cblock,node,sym_get_ref,1,1,& + call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1,& aflags=merge(proc_run_complete+proc_run_always,0,& coder%par_state>par_state_outer)) else @@ -4367,8 +3214,6 @@ recursive subroutine trav_structrec(coder,cblock,node) enddo ! Set up struct/rec creation call - call make_temp_var(coder,cblock,node) - call dup_code(coder) basex=coder%vtop info=trav_structrec_decl(coder,decl,decl) call make_const(coder,cblock,node,info) @@ -4427,7 +3272,7 @@ recursive subroutine trav_structrec(coder,cblock,node) call pm_panic('trav_structrec') endif endif - call make_sp_call(coder,cblock,node,sym,n+2,1,flags=coder%run_flags) + call make_sp_call_rtn(coder,cblock,node,sym,n+2,1,flags=coder%run_flags) coder%vstack(vbase+1)=coder%vstack(coder%vtop) coder%vtop=vbase+1 @@ -4482,14 +3327,10 @@ recursive subroutine make_cast(coder,cblock,node,tno) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: tno - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call make_const(coder,cblock,node,& pm_fast_tinyint(coder%context,tno),int(pm_tiny_int)) - call make_sp_call(coder,cblock,node,sym_type_val,1,1) - call make_sys_call(coder,cblock,node,sym_as,2,1) + call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_as,2,1) contains include 'ftiny.inc' end subroutine make_cast @@ -4628,17 +3469,43 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_unique) name=node_arg(node,1) call push_word(coder,pm_new_name_type(coder%context,int(name%offset))) - case(sym_dash) + case(sym_fix) name=node_arg(node,1) - if(pm_fast_isname(name)) then - if(name%offset==sym_true) then - call push_word(coder,coder%true_fix) - else - call push_word(coder,coder%false_fix) + select case(node_sym(name)) + case(sym_true) + call push_word(coder,coder%true_fix) + case(sym_false) + call push_word(coder,coder%false_fix) + case(sym_number,sym_string) + call push_word(coder,pm_new_fix_type(coder%context,node_arg(name,1))) + case default + call push_word(coder,pm_type_new_fix) + call push_word(coder,0) + call trav_type(coder,pnode,name) + call make_type(coder,3) + end select + case(sym_literal) + name=node_arg(node,1) + select case(node_sym(name)) + case(sym_true) + call push_word(coder,coder%true_literal) + case(sym_false) + call push_word(coder,coder%false_literal) + case(sym_number,sym_string) + call push_word(coder,pm_new_literal_type(coder%context,name)) + case default + call push_word(coder,pm_type_new_unfixed) + call push_word(coder,0) + call trav_type(coder,pnode,name) + typno=pm_type_strip_to_basic(coder%context,pop_word(coder)) + if(typno/=0.and.typno/=pm_long.and.typno/=pm_double.and.& + typno/=pm_logical.and.typno/=pm_string_type) then + call code_error(coder,node,'Cannot have a literal type for: '//& + trim(pm_type_as_string(coder%context,typno))) endif - else - call push_word(coder,pm_new_fix_type(coder%context,name)) - endif + call push_word(coder,typno) + call make_type(coder,3) + end select case(sym_contains) call push_word(coder,pm_type_new_contains) call push_word(coder,0) @@ -4700,11 +3567,6 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,pm_type_new_bottom) call push_word(coder,0) call make_type(coder,2) - case(sym_fix) - call push_word(coder,pm_type_new_fix) - call push_word(coder,0) - call trav_type(coder,pnode,node_arg(node,1)) - call make_type(coder,3) case(sym_const) call push_word(coder,pm_type_new_unfixed) call push_word(coder,0) @@ -4738,11 +3600,6 @@ recursive subroutine trav_type(coder,pnode,node) call trav_type(coder,pnode,node_arg(node,i)) enddo call make_type(coder,n+1) - case(sym_amp) - call push_word(coder,pm_type_new_amp) - call push_word(coder,0) - call trav_type(coder,pnode,node_arg(node,1)) - call make_type(coder,3) case(sym_mode) call trav_type(coder,pnode,node_arg(node,1)) typno=pop_word(coder) @@ -4840,7 +3697,7 @@ end subroutine trav_type !================================================================= ! Traverse a type reference T or T(args) - ! - type node should be of the form args type_name + ! - type node is of the form args type_name ! - process any associated type definition, if not already cached !================================================================= recursive subroutine trav_type_decl(coder,pnode,node) @@ -4883,8 +3740,9 @@ recursive subroutine trav_type_decl(coder,pnode,node) write(*,*) '}' endif - ! Check if this is a type variable base=coder%wtop + + ! Check if this is a type variable if(nargs==0.and.pm_fast_isname(namenode)) then decl=find_type_var(coder,name) if(.not.pm_fast_isnull(decl)) then @@ -5190,7 +4048,7 @@ subroutine check_constraints(tno,node) type(pm_ptr):: constraints integer:: i - ! Make an entry for each "<: type" entry to be checked later + ! Make an entry for each ": type" entry to be checked later constraints=node_get(main_dec,type_constraints) do i=1,node_numargs(constraints) call trav_type(coder,main_dec,node_arg(constraints,i)) @@ -5587,7 +4445,7 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: nret logical,intent(in):: amps_ok - type(pm_ptr):: list,procs,keys,sig,name,amp,prvar,proc,p,arg + type(pm_ptr):: list,procs,keys,keynames,sig,name,amp,prvar,proc,p,arg integer:: flags,i,j,nargs,nkeys,ampbase,vsym,outmode,nref integer:: depth,otop,obase,owbase,base,abase,atop,babase,astart logical:: iscomm,outer,has_shared_amp_arg,need_alias_checks,shared_ref_ok @@ -5600,51 +4458,28 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) ! Determine properties of call name=node_arg(node,1) list=node_arg(node,2) - keys=node_arg(node,3) - amp=node_arg(node,4) - flags=node_get_num(node,node_args+4) - shared_ref_ok=iand(flags,call_ignore_rules+proc_run_shared+proc_run_local+call_is_comm)/=0 + amp=node_arg(node,3) + keys=node_arg(node,4) + keynames=node_arg(node,5) + flags=node_num_arg(node,6) + if(node_sym(list)==sym_dotdotdot) then flags=ior(flags,call_is_vararg) endif - if(iand(flags,proc_run_local+proc_run_shared)/=0) then - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot have <> call attribute outside of a parallel context',& - name) - endif - endif nargs=node_numargs(list) + if(debug_codegen) then write(*,*) 'TRAV CALL>',& trim(pm_name_as_string(coder%context,int(name%offset))),& nargs,nret,coder%vtop,flags - write(*,*) 'TOP==',coder%top endif - ! Extra argument for comm calls - if(iand(flags,call_is_comm)/=0) then - iscomm=.true. - call check_par_context(coder,cblock,node,pm_fast_isnull(amp)) - - ! Comm call (& its args) operates in standard run mode - ! - not the current one - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - coder%run_mode=sym_complete - coder%run_flags=0 - elseif(iand(flags,proc_run_shared+proc_run_local)/=0) then - call check_par_context(coder,cblock,node,pm_fast_isnull(amp)) - iscomm=.false. - elseif(iand(flags,proc_run_complete)/=0) then - call check_par_context(coder,cblock,node,.false.) - iscomm=.false. - else - iscomm=.false. - endif + iscomm=iand(flags,call_is_comm)/=0 base=coder%vtop has_shared_amp_arg=.false. + + ! write(*,*) 'AMP',pm_fast_isnull(amp),trim(pm_name_as_string(coder%context,int(name%offset))) ! Standard arguments if(pm_fast_isnull(amp)) then @@ -5655,16 +4490,11 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) else if(.not.amps_ok) then call code_error(coder,list,& - 'Call using "&" or "&&" arguments cannot be a component of an expression') + 'Call using "&" arguments cannot be a component of an expression') endif amp=pm_name_val(coder%context,int(amp%offset)) flags=ior(flags,call_is_assign_call) - - ! Make space on vstack to store in/out temp vars for amp args - ampbase=coder%vtop - coder%vstack(coder%vtop+1:coder%vtop+nargs)=pm_null_obj - coder%vtop=coder%vtop+nargs ! Alias checks if needed nref=0 @@ -5673,10 +4503,8 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) do j=0,pm_fast_esize(amp) i=amp%data%i(amp%offset+j) arg=node_arg(list,i) - if(node_sym(arg)==sym_amp) then - call trav_alias_checks(coder,cblock,list,amp,i,ampbase) - nref=nref+1 - endif + call trav_alias_checks(coder,cblock,list,amp,i,ampbase) + nref=nref+1 enddo endif atop=coder%top @@ -5689,45 +4517,34 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) do i=1,nargs if(amp%data%i(amp%offset+j)==i) then arg=node_arg(list,i) - if(node_sym(arg)==sym_amp) then - outmode=trav_ref(coder,cblock,list,& - node_arg(arg,1),& - merge(ref_ignores_rules+ref_is_amp,ref_is_amp,shared_ref_ok)) - else - call make_temp_var(coder,cblock,list) - call dup_code(coder) - call trav_expr(coder,cblock,list,arg) - call make_basic_sys_call(coder,cblock,node,sym_clone,1,1,& - coder%par_depth,call_ignore_rules) - coder%vstack(ampbase+i)=top_code(coder) - endif + outmode=trav_ref(coder,cblock,list,& + arg,merge(ref_ignores_rules+ref_is_amp,ref_is_amp,iscomm)) j=min(pm_fast_esize(amp),j+1) else arg=node_arg(list,i) - coder%aliased=.false. call trav_expr(coder,cblock,list,arg) - if(coder%aliased) then - if(node_sym(arg)==sym_dot.or.& - node_sym(arg)==sym_sub) then - arg=coder%vstack(ampbase+i) - if(pm_fast_vkind(arg)==pm_tiny_int) then - !write(*,*) 'nref=',nref,arg%offset,'#',i - if(arg%offset==nref) cycle - endif - endif - call make_temp_var(coder,cblock,list) - call swap_and_dup_code(coder) - call make_sys_call(coder,cblock,node,sym_clone,1,1) - coder%aliased=.false. - endif endif enddo call hide_vars(coder,abase+1,atop) endif babase=merge(base+3,base+1,iscomm) + call make_arglist(coder,cblock,node,nargs,nret,iscomm) + + ! Keyword arguments + if(.not.pm_fast_isnull(keys)) then + nkeys=node_numargs(keys) + do i=1,nkeys + call trav_expr(coder,cblock,node,node_arg(keys,i)) + enddo + call make_arglist(coder,cblock,node,nkeys,0,iscomm) + else + nkeys=0 + call code_null(coder) + endif + ! Find procs with this signature - amp=node_arg(node,4) + amp=node_arg(node,3) proc=pm_null_obj if(pm_fast_isname(name)) then proc=find_decl(coder,node,name,modl_proc) @@ -5759,11 +4576,9 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) node_arg(name,2),modl_proc) endif case(sym_method_call) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call code_val(coder,coder%vstack(babase)) call make_const(coder,cblock,node,node_arg(name,1)) - call make_sp_call(coder,cblock,node,sym_method_call,2,1) + call make_sp_call_rtn(coder,cblock,node,sym_method_call,2,1) case default write(*,*) sym_names(vsym) call pm_panic('Bad VSYM in trav_call') @@ -5773,15 +4588,17 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif endif + !write(*,*) '++++>',coder%vtop,trim(pm_name_as_string(coder%context,int(name%offset))) + if(.not.pm_fast_isnull(proc)) then prvar=pm_null_obj - procs=find_sig(coder,node,name,& - amp,nargs,nret,flags,sig,iscomm,procroot=proc) + procs=find_sig(coder,node,name) else prvar=pop_code(coder) - procs=find_vcall_sig(coder,node,amp,& - nargs,nret,flags,sig,iscomm) + procs=pm_fast_tinyint(coder%context,0) endif + + !write(*,*) '++++=>',coder%vtop,trim(pm_name_as_string(coder%context,int(name%offset))) ! Error return if no such proc if(pm_fast_isnull(procs)) then @@ -5789,71 +4606,33 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) return endif - ! Keyword arguments (need sig first) - if(.not.pm_fast_isnull(prvar).and..not.pm_fast_isnull(keys)) then - call code_error(coder,keys,'Cannot have keyword arguments in ".()" call') - nkeys=0 - else - nkeys=trav_keys(coder,cblock,keys,sig,iscomm) - endif - - ! Swap keyword and standard args - if(nkeys>0) then - call check_vstack(coder,nargs) - do i=base+1,base+nargs - coder%vtop=coder%vtop+1 - coder%vstack(coder%vtop)=coder%vstack(i) - enddo - do i=base+nargs+1,coder%vtop - coder%vstack(i-nargs)=coder%vstack(i) - enddo - coder%vtop=coder%vtop-nargs - endif - - ! Debugging trace - if(debug_codegen) then - if(pm_fast_isname(name)) then - write(*,*) 'TRAV CALL MAKE FULL CALL>',& - trim(pm_name_as_string(coder%context,int(name%offset))),& - nargs,nret,nkeys,coder%vtop - else - write(*,*) 'TRAV CALL MAKE FULL CALL> .proc ',& - nargs,nret,nkeys,coder%vtop - endif - - do i=coder%vtop-nargs-nkeys-nret+1,coder%vtop - call qdump_code_tree(coder,pm_null_obj,6,coder%vstack(i),2) - enddo - write(*,*) 'TRAV CALL END MAKE FULL CALL>' - endif +!!$ ! Keyword arguments (need sig first) +!!$ if(.not.pm_fast_isnull(prvar).and..not.pm_fast_isnull(keys)) then +!!$ call code_error(coder,keys,'Cannot have keyword arguments in ".()" call') +!!$ nkeys=0 +!!$ else +!!$ nkeys=trav_keys(coder,cblock,keys,sig,iscomm) +!!$ endif - flags=ior(flags,coder%run_flags) - if(coder%par_state>=par_state_cond.and.& - iand(flags,proc_run_complete+proc_run_shared+proc_run_local)==0) then + if(coder%par_state>=par_state_cond) then flags=ior(flags,call_is_cond) endif + if(coder%par_state==par_state_cond.or.& coder%par_state==par_state_par) then flags=ior(flags,call_is_unlabelled) endif ! Make the call - call import_args(coder,cblock,node,nargs,nret,nkeys,amp,flags,abase) + !call import_args(coder,cblock,node,nargs,nret,nkeys,amp,flags,abase) + + !write(*,*) '==>',obase,coder%vtop,nargs,nret + call make_full_call(coder,cblock,node,procs,amp,& - nargs,nret,nkeys,flags,prvar,coder%par_depth) - - ! Write out && args - if(.not.pm_fast_isnull(amp)) then - amp=pm_name_val(coder%context,int(amp%offset)) - do i=0,pm_fast_esize(amp) - j=amp%data%i(amp%offset+i) - if(.not.pm_fast_isnull(coder%vstack(ampbase+j))) then - call code_val(coder,coder%vstack(ampbase+j)) - call make_assignment_noalias(coder,cblock,list,node_arg(list,j)) - endif - enddo - coder%vtop=obase-nret - endif + nargs,nret,nkeys,keynames,flags,prvar,coder%par_depth) + + !write(*,*) '===>',obase,coder%vtop,nargs,nret + ! If this is a variable call, flag the variable if(.not.pm_fast_isnull(prvar)) then @@ -5866,16 +4645,14 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif endif - ! Restore run mode/run flags for comm calls - if(iscomm) then - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - endif - + if(.not.pm_fast_isnull(amp)) coder%vtop=obase-nret + ! If debugging, check tidy up if(pm_debug_checks) then if(coder%vtop/=obase-nret.or.coder%wtop/=owbase) then - write(*,*) obase,nret,obase-nret,coder%vtop,owbase,coder%wtop,nargs,otop,coder%top + write(*,*) obase,nret,obase-nret,coder%vtop,owbase,coder%wtop,nargs,otop,& + coder%top,pm_fast_isnull(amp),& + trim(pm_name_as_string(coder%context,int(name%offset))) call pm_panic('trav call') endif endif @@ -5891,6 +4668,7 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) include 'fisname.inc' include 'fesize.inc' include 'fvkind.inc' + include 'ftiny.inc' end subroutine trav_call !=========================================================================== @@ -5979,26 +4757,25 @@ recursive function trav_keys(coder,cblock,list,sig,iscomm) result(nkeys) include 'ftiny.inc' end function trav_keys - !=============================================================== ! Traverse procedure definition !=============================================================== - recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& - amplocs,nret,procs,numprocs,lclbase) + recursive subroutine trav_proc(coder,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,node,amplocs,keyargs,procs - integer,intent(in):: nargs,nret,numprocs,lclbase + type(pm_ptr),intent(in):: node + integer:: nargs,nret type(pm_ptr):: cblock,cblock2,cblock3,cblock4 - type(pm_ptr):: p,par,amp,rtypes,arg,rv,tkeys - integer:: i,j,n,base,obase,wbase,npars,cbase,nkeyargs + type(pm_ptr):: p,par,amp,rtypes,arg,rv,keycall,argcall + type(pm_ptr),target:: tkeys + integer:: i,j,n,base,obase,wbase,npars,cbase integer:: flags,sym,loop_pars,reduce_base,reduce_start,rsig integer:: partyp integer:: save_index,t integer:: save_proc_base,& save_par_base, save_over_base,save_proc_par_depth,& save_proc_nret,save_par_state,save_proc_ncalls,& - save_subs_index,save_if_scope,save_run_mode,save_run_flags + save_subs_index,save_lex_scope,save_run_mode,save_run_flags type(pm_ptr):: save_sub_array,save_loop_cblock, & save_proc_keys,save_label logical:: save_aliased,save_in_sync @@ -6008,6 +4785,11 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& logical:: complete,old_complete integer,save:: pdepth=0 + nargs=node_numargs(node_get(node,proc_params))/2 + nret=node_get_num(node,proc_numret) + !amps=node_get(node,proc_amplocs) + !keyargs=pm_null_obj + if(debug_codegen) then write(*,*) repeat(' ',pdepth),'TRAV PROC>',& trim(pm_name_as_string(coder%context,& @@ -6016,18 +4798,19 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& pdepth=pdepth+1 endif - if(pm_fast_isnull(keyargs)) then - nkeyargs=0 - else - nkeyargs=pm_set_size(coder%context,keyargs) - endif + !nkeyargs=0 ! Parameter types wbase=coder%wtop obase=coder%vtop - partyp=proc_param_type(coder,node) - call code_num(coder,int(partyp)) - if(coder%wtop/=wbase) call pm_panic('par type wstack mismatch') + + call code_num(coder,proc_param_type(coder,node)) + call code_num(coder,proc_result_type(coder,node)) + call code_num(coder,nargs) + call code_num(coder,nret) + call code_num(coder,flags) + call code_val(coder,node_get(node,proc_amplocs)) + call code_val(coder,node_get(node,proc_name)) sym=node_sym(node) if(sym==sym_builtin) then @@ -6042,59 +4825,10 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& cbase=coder%vtop call code_val(coder,node_get(node,proc_opcode)) call code_val(coder,node_get(node,proc_opcode2)) - call code_val(coder,node_get(node,proc_data)) - call code_val(coder,node_get(node,proc_flags)) - call code_num(coder,proc_result_type(coder,node)) - if(nret>0) then - p=node_get(node,proc_retas) - if(pm_fast_istiny(p)) then - call code_val(coder,p) - call code_num(coder,0) - elseif(pm_fast_isnull(p)) then - p=node_get(node,proc_result_types) - if(node_sym(p)==sym_dash) then - call code_null(coder) - call code_num(coder,sym_dash) - else - call code_null(coder) - call code_num(coder,0) - endif - else - call save_proc_state - call init_proc_state - cblock=make_cblock(coder,pm_null_obj,node,sym_present) - npars=0 - call code_params(cblock,.false.) - sym=node_sym(p) - p=node_arg(p,1) - base=coder%vtop - call trav_xexpr(coder,cblock,node,p) - call make_sp_call(coder,cblock,node,& - sym_result,coder%vtop-base,0) - coder%vtop=base - call close_cblock(coder,cblock) - call code_num(coder,sym) - call restore_proc_state - endif - else - call code_null(coder) - call code_num(coder,0) - endif - endif - coder%id=coder%id+1 - call code_num(coder,coder%id) - if(pm_debug_checks) then - if(coder%vtop-cbase/=bi_node_size) then - write(*,*) '===========',coder%vtop,cbase,cbase+bi_node_size - do i=cbase+1,coder%vtop - call qdump_code_tree(coder,pm_null_obj,6,& - coder%vstack(i),2) - write(*,*) '====' - enddo - call pm_panic('making bi') - endif - endif - call make_code(coder,node,cnode_is_builtin,bi_node_size) + coder%id=coder%id+1 + call code_num(coder,coder%id) + call make_code(coder,node,cnode_is_builtin,bi_node_size) + end if else ! User-defined procedure @@ -6106,8 +4840,6 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& return endif - write(70,*) trim(pm_name_as_string(coder%context,& - node_get_num(node,proc_name))),'par',coder%par_state old_complete=coder%par_statepm_register(coder%context,'tproc',tkeys) @@ -6124,92 +4857,71 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& npars=0 flags=node_get_num(node,proc_flags) pr_flags=flags - if(iand(flags,proc_is_each_proc)==0) then - if(iand(flags,proc_is_comm+proc_run_shared+proc_run_local)==& - proc_is_comm) then - loop_pars=coder%top - if(iand(flags,proc_run_complete)/=0) then - complete=.true. - call check_param_modes(sym_complete,sym_complete) - elseif(iand(flags,proc_is_uncond)/=0) then - complete=.true. - elseif(iand(flags,proc_is_cond)/=0) then - complete=.false. - else - complete=old_complete - endif - call code_params(cblock,.true.) - call code_keys(cblock,tkeys) - call code_loop_startup(cblock,cblock2,cblock3) - call code_check(cblock3) - call code_body(cblock3) - call code_result(cblock3,flags) - call code_loop_finish(cblock,cblock2,cblock3) + if(iand(flags,proc_is_comm)/=0) then + loop_pars=coder%top + if(iand(flags,proc_run_complete)/=0) then + complete=.true. + call check_param_modes(sym_complete,sym_complete) + elseif(iand(flags,proc_is_uncond)/=0) then + complete=.true. + elseif(iand(flags,proc_is_cond)/=0) then + complete=.false. else - if(iand(flags,proc_run_shared+proc_run_local)/=0) then - loop_pars=coder%top - call check_param_modes(sym_mirrored,sym_shared) - call code_params(cblock,.true.) - call export_params - else - call code_params(cblock,.false.) - endif - call code_keys(cblock,tkeys) - call code_check(cblock) - call code_body(cblock) - call code_result(cblock,flags) + complete=old_complete endif + call code_params(cblock,.true.,argcall) + call code_keys(cblock,tkeys,keycall) + call code_loop_startup(cblock,cblock2,cblock3) + call code_check(cblock3) + call code_body(cblock3) + call code_result(cblock3,flags) + call code_loop_finish(cblock,cblock2,cblock3) else - pr_flags=ior(pr_flags,proc_is_each_proc) - call code_proc_each - endif - call close_cblock(coder,cblock) - - if(pm_debug_checks) then - if(coder%vtop/=obase+2) then - write(*,*) coder%vtop,obase+2 - do i=obase+3,coder%vtop - write(*,*) '===================' - call qdump_code_tree(coder,pm_null_obj,6,& - coder%vstack(i),2) - write(*,*) '===================' - enddo - write(*,*) sym_names(sym) - call pm_panic( 'Proc cnode mismatch' ) - endif - if(coder%wtop/=wbase) then - write(*,*) coder%wtop,wbase - call pm_panic('proc wstack mismatch') + if(iand(flags,proc_run_shared+proc_run_local)/=0) then + loop_pars=coder%top + call check_param_modes(sym_mirrored,sym_shared) + call code_params(cblock,.true.,argcall) + call export_params + else + call code_params(cblock,.false.,argcall) endif + call code_keys(cblock,tkeys,keycall) + call code_check(cblock) + call code_body(cblock) + call code_result(cblock,flags) endif - write(70,*) trim(pm_name_as_string(coder%context,& - node_get_num(node,proc_name))),pr_flags,complete,old_complete,coder%par_state - + call close_cblock(coder,cblock) ! Create proc code object call code_num(coder,coder%index) ! Maximum index call code_num(coder,0) ! Recursion flag coder%id=coder%id+1 call code_num(coder,coder%id) ! Procedure id. index - call code_num(coder,proc_result_type(coder,node)) ! Return type - call code_num(coder,npars) ! Number of parameters - call code_num(coder,0) ! Number of keywords - ! (fixed later) - call code_num(coder,nret) ! Number of returns - call code_num(coder,pr_flags) ! Flags - call code_num(coder,node_get_num(node,proc_name)) ! Name call code_num(coder,coder%proc_ncalls) ! Number of calls call code_val(coder,tkeys) ! Keyword arg info + call code_val(coder,keycall) ! Keyword call + call code_val(coder,argcall) ! Arguments call call make_code(coder,node,cnode_is_proc,pr_node_size) call pm_delete_register(coder%context,reg) - call pop_par_scope(coder,cblock,node) +!!$ call pop_par_scope(coder,cblock,node) + coder%par_depth=coder%par_depth-1 + call restore_proc_state endif + if(pm_debug_checks) then + if(coder%vtop/=obase+1) then + call pm_panic('trav_proc: vstack') + endif + if(coder%wtop/=wbase) then + call pm_panic('trav_proc: vstack') + endif + endif + if(debug_codegen) then pdepth=pdepth-1 write(*,*) repeat(' ',pdepth),'END TRAV PROC>',& @@ -6230,13 +4942,12 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& subroutine save_proc_state save_index=coder%index - save_if_scope=coder%if_scope + save_lex_scope=coder%lex_scope save_proc_base=coder%proc_base save_proc_ncalls=coder%proc_ncalls save_par_base=coder%par_base save_over_base=coder%over_base save_loop_cblock=coder%loop_cblock - save_proc_keys=coder%proc_keys save_proc_par_depth=coder%proc_par_depth save_proc_nret=coder%proc_nret save_par_state=coder%par_state @@ -6250,12 +4961,11 @@ end subroutine save_proc_state subroutine init_proc_state coder%index=0 - coder%if_scope=0 + coder%lex_scope=0 coder%proc_base=coder%top coder%proc_ncalls=0 coder%par_base=coder%top coder%over_base=coder%top+2 - coder%proc_keys=keyargs coder%proc_par_depth=coder%par_depth coder%proc_nret=nret coder%par_state=par_state_outer @@ -6268,13 +4978,12 @@ end subroutine init_proc_state subroutine restore_proc_state coder%index=save_index - coder%if_scope=save_if_scope + coder%lex_scope=save_lex_scope coder%proc_base=save_proc_base coder%proc_ncalls=save_proc_ncalls coder%par_base=save_par_base coder%over_base=save_over_base coder%loop_cblock=save_loop_cblock - coder%proc_keys=save_proc_keys coder%par_depth=coder%proc_par_depth coder%proc_par_depth=save_proc_par_depth coder%proc_nret=save_proc_nret @@ -6287,9 +4996,10 @@ subroutine restore_proc_state coder%in_sync=save_in_sync end subroutine restore_proc_state - subroutine code_params(cblock,iscomm) + subroutine code_params(cblock,iscomm,argcall) type(pm_ptr),intent(in):: cblock logical,intent(in):: iscomm + type(pm_ptr),intent(out):: argcall type(pm_ptr):: name,var,p integer:: state,flags,cflags p=node_get(node,proc_params) @@ -6300,15 +5010,7 @@ subroutine code_params(cblock,iscomm) flags=var_is_param name=node_arg(p,i) if(name%offset==sym_arg) flags=var_is_varg - if(iscomm.and.i>3) then - cflags=coder%wstack(lclbase+(i+1)/2) - call make_var(coder,cblock,p,name,flags) - if(iand(cflags,var_is_imported)==0) then - call var_set_par_depth(coder,top_code(coder),coder%par_depth+1) - endif - else - call make_var(coder,cblock,p,name,flags) - endif + call make_var(coder,cblock,p,name,flags) enddo else j=0 @@ -6325,20 +5027,15 @@ subroutine code_params(cblock,iscomm) endif name=node_arg(p,i) if(name%offset==sym_arg) flags=var_is_varg - if(iscomm.and.i>3) then - cflags=coder%wstack(lclbase+(i+1)/2) - call make_var(coder,cblock,p,name,flags) - if(iand(cflags,var_is_imported)==0) then - call var_set_par_depth(coder,top_code(coder),coder%par_depth+1) - endif - else - call make_var(coder,cblock,p,name,flags) - endif + call make_var(coder,cblock,p,name,flags) enddo endif npars=npars+node_numargs(p)/2 call make_basic_sp_call(coder,cblock,p,& sym_open,npars,0,coder%par_depth) + argcall=cnode_get(cnode_get(cblock,cblock_last_call),call_args) + else + argcall=pm_null_obj endif end subroutine code_params @@ -6348,15 +5045,12 @@ subroutine export_params p=node_get(node,proc_params) do i=2,npars var=coder%var(loop_pars+i) - flags=coder%wstack(lclbase+i) - if(iand(flags,var_is_imported)==0) then - call make_var(coder,cblock,p,cnode_get(var,var_name),& - ior(iand(cnode_get_num(var,var_flags),& - var_is_var+var_is_ref),var_is_shadowed)) - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,p,sym_export_param,& - 1,1,coder%par_depth) - endif + call make_var(coder,cblock,p,cnode_get(var,var_name),& + ior(iand(cnode_get_num(var,var_flags),& + var_is_var+var_is_ref),var_is_shadowed)) + call code_val(coder,var) + call make_basic_sp_call(coder,cblock,p,sym_export_param,& + 1,1,coder%par_depth) enddo end subroutine export_params @@ -6384,64 +5078,89 @@ subroutine check_param_modes(mode,flag_sym) arg=node_arg(p,i) if(node_sym(arg)==sym_mode) then call code_error(coder,node,& - 'Return modes for a "<<'//trim(sym_names(flag_sym))//& + 'Return modes for a "<<'//& + trim(sym_names(flag_sym))//& '>>" procedure must be undefined or "'//& trim(sym_names(mode))) endif enddo end subroutine check_param_modes - - recursive subroutine code_keys(cblock,tkeys) + + recursive subroutine code_keys(cblock,tkeys,key_call) type(pm_ptr),intent(in):: cblock - type(pm_ptr),intent(inout):: tkeys - type(pm_ptr):: vname,arg - integer:: tbase,vb,base - ! Keyword arguments + type(pm_ptr),intent(inout):: key_call + type(pm_ptr),intent(inout),target:: tkeys + type(pm_ptr):: p,vname,typ,cblock2 + integer:: i,n,base,vbase,wbase,tno + p=node_get(node,proc_keys) - if(.not.pm_fast_isnull(p)) then - base=coder%vtop - tbase=coder%wtop - do i=1,node_numargs(p),3 - vname=node_arg(p,i) - call make_var(coder,cblock,p,vname,& - var_is_key+var_is_multi_access) - vb=coder%top - call hide_vars(coder,coder%top,vb) ! Stop recursive use of tag name - call make_sys_var(coder,cblock,p,& - pm_name2(coder%context,sym_present,& - int(vname%offset)),var_is_multi_access) - j=pm_set_lookup(coder%context,keyargs,node_arg(p,i)) - if(pm_debug_checks) then - if(j<0) call pm_panic('lookup key arg') - endif - ! key= sym_present(nret,j,default, [type]) - call make_int_const(coder,cblock,p,nret) - call make_int_const(coder,cblock,p,j) - call trav_expr(coder,cblock,p,node_arg(p,i+2)) - call reveal_vars(coder,vb,vb) - if(.not.pm_fast_isnull(node_arg(p,i+1))) then - call push_word(coder,(i+2)/3) - arg=node_arg(p,i+1) - call trav_type(coder,arg,arg) - call make_int_const(coder,cblock,p,top_word(coder)) - call make_sp_call(coder,cblock,p,& - sym_present,4,2) - else - call make_sp_call(coder,cblock,p,& - sym_present,3,2) - endif - enddo - ! Create tkeys (defined in parent subroutine) with vector of type constraints - if(coder%wtop>tbase) then - tkeys=pm_fast_newnc(coder%context,pm_int,coder%wtop-tbase) - tkeys%data%i(tkeys%offset:tkeys%offset+coder%wtop-tbase-1)=& - coder%wstack(tbase+1:coder%wtop) - coder%wtop=tbase + if(pm_fast_isnull(p)) then + tkeys=pm_null_obj + key_call=pm_null_obj + return + endif + n=node_numargs(p)/3 + vbase=coder%vtop + base=coder%top + + ! Create actual keyword parameter variables + wbase=coder%wtop + do i=1,node_numargs(p),3 + vname=node_arg(p,i) + call push_word(coder,int(vname%offset)) + call make_var(coder,cblock,p,vname,& + var_is_param+var_is_key+var_is_multi_access) + enddo + + ! Create a vector of all key names followed by all key types + ! and finally by largest index associated with keys + do i=1,node_numargs(p),3 + typ=node_arg(p,i+1) + if(pm_fast_isnull(typ)) then + call push_word(coder,-1) + else + call trav_type(coder,p,typ) endif - if(pm_debug_checks) then - if(base/=coder%vtop) call pm_panic('trav_proc key mismatch') + enddo + tkeys=pm_fast_newnc(coder%context,pm_int,coder%wtop-wbase+1) + tkeys%data%i(tkeys%offset:tkeys%offset+coder%wtop-wbase-1)=& + coder%wstack(wbase+1:coder%wtop) + coder%wtop=wbase + + ! Create visible keyword parameters + do i=1,node_numargs(p),3 + vname=node_arg(p,i) + call make_var(coder,cblock,p,vname,& + var_is_key+var_is_multi_access+var_is_shadowed,& + extra_info=coder%var(base+(i+2)/3)) + enddo + + call hide_vars(coder,base+1,coder%top) + + ! Create blocks to compute default values + do i=1,node_numargs(p),3 + cblock2=make_cblock(coder,cblock,node,sym_key) + call trav_expr(coder,cblock2,p,node_arg(p,i+2)) + tno=tkeys%data%i(tkeys%offset+n+i-1) + ! For stated type constraints, convert default value to + ! that type + if(tno>=0) then + call make_const(coder,cblock2,node,& + pm_fast_tinyint(coder%context,tno)) + call make_sp_call_rtn(coder,cblock2,node,sym_type_val,1,1) + call make_sp_call_rtn(coder,cblock2,node,sym_cast,2,1) endif - endif + call close_cblock(coder,cblock2) + call reveal_vars(coder,base+n+(i+2)/3,base+n+(i+2)/3) + enddo + + ! Create call: key keyarg... keyvar... (block defvar)... + call make_sp_call(coder,cblock,node,sym_key,n*2,n*2) + key_call=cnode_get(cnode_get(cblock,cblock_last_call),call_args) + + ! Last index used by default expressions + tkeys%data%i(tkeys%offset+pm_fast_esize(tkeys))=coder%index + end subroutine code_keys recursive subroutine code_check(cblock) @@ -6474,7 +5193,7 @@ recursive subroutine code_result(cblock,flags) if(.not.pm_fast_isnull(p)) then base=coder%vtop call trav_xexpr(coder,cblock,node,p) - if(iand(flags,proc_run_shared+proc_run_local)/=0) then + if(iand(flags,proc_run_shared+proc_run_local)/=0) then do i=coder%vtop+1-nret,coder%vtop call make_temp_var(coder,cblock,node) call dup_code(coder) @@ -6512,192 +5231,76 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) integer:: iter - !coder%over_base=coder%top - call push_var(coder,sym_for,& - coder%var(loop_pars+1)) - - - call make_sys_var(coder,cblock,node,sym_in,0) - - iter=coder%top - coder%par_base=iter - call make_sys_var(coder,cblock,node,sym_pling,var_is_shadowed) - call code_val(coder,coder%var(iter+lv_distr)) - call make_sys_call(coder,cblock,node,sym_get_tile_sz,1,2) - call make_sys_var(coder,cblock,node,sym_hash,var_is_shadowed) - call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) - call drop_code(coder) - cblock2=make_cblock(coder,cblock,node,sym_proc) - coder%loop_cblock=cblock2 - call drop_code(coder) - - ! Alias the region and subregion variables - call push_var(coder,sym_region,coder%var(iter+lv_distr)) - call push_var(coder,sym_subregion,coder%var(loop_pars+2)) - coder%over_base =coder%top - - call push_par_scope(coder,cblock2) - call push_var(coder,sym_here_in_tile,coder%var(loop_pars+3)) - call make_sys_var(coder,cblock2,node,sym_here,var_is_shadowed) - call code_val(coder,coder%var(iter+lv_tile)) - call code_val(coder,coder%var(iter+lv_index)) - call make_sys_call(coder,cblock2,node,sym_get_element,2,1) - +!!$ !coder%over_base=coder%top +!!$ call push_var(coder,sym_for,& +!!$ coder%var(loop_pars+1)) +!!$ +!!$ +!!$ call make_sys_var(coder,cblock,node,sym_in,0) +!!$ +!!$ iter=coder%top +!!$ coder%par_base=iter +!!$ call make_sys_var(coder,cblock,node,sym_pling,var_is_shadowed) +!!$ call code_val(coder,coder%var(iter+lv_distr)) +!!$ call make_sys_call(coder,cblock,node,sym_get_tile_sz,1,2) +!!$ call make_sys_var(coder,cblock,node,sym_hash,var_is_shadowed) +!!$ call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) +!!$ call drop_code(coder) +!!$ cblock2=make_cblock(coder,cblock,node,sym_proc) +!!$ coder%loop_cblock=cblock2 +!!$ call drop_code(coder) +!!$ +!!$ ! Alias the region and subregion variables +!!$ call push_var(coder,sym_region,coder%var(iter+lv_distr)) +!!$ call push_var(coder,sym_subregion,coder%var(loop_pars+2)) +!!$ coder%over_base =coder%top +!!$ +!!$ call push_par_scope(coder,cblock2) +!!$ call push_var(coder,sym_here_in_tile,coder%var(loop_pars+3)) +!!$ call make_sys_var(coder,cblock2,node,sym_here,var_is_shadowed) +!!$ call code_val(coder,coder%var(iter+lv_tile)) +!!$ call code_val(coder,coder%var(iter+lv_index)) +!!$ call make_sys_call(coder,cblock2,node,sym_get_element,2,1) +!!$ !!$ if(iter+lv_here/=coder%top) then !!$ write(*,*) '#',iter+lv_here,coder%top !!$ call pm_panic('iter mismatch in code_loop_startup') !!$ endif - - coder%par_state=par_state_for - coder%run_mode=sym_complete - - coder%par_state=merge(par_state_for,par_state_masked,complete) - - if(complete) pr_flags=ior(pr_flags,proc_run_complete) - cblock3=make_cblock(coder,cblock2,node,sym_for_stmt) - - if(pm_is_compiling) then - ! Call PM__do_over to set-up subset loops - call make_sys_var(coder,cblock3,node,sym_nested_loop,var_is_shadowed) - call dup_code(coder) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_distr)) - call make_basic_sys_call(coder,cblock3,node,sym_do_over,2,1,& - coder%par_depth-1,call_inline_when_compiling) - call make_basic_sys_call(coder,cblock3,node,sym_nested_loop,1,0,& - coder%par_depth-1,call_inline_when_compiling) - endif +!!$ +!!$ coder%par_state=par_state_for +!!$ coder%run_mode=sym_complete +!!$ +!!$ coder%par_state=merge(par_state_for,par_state_masked,complete) +!!$ +!!$ if(complete) pr_flags=ior(pr_flags,proc_run_complete) +!!$ cblock3=make_cblock(coder,cblock2,node,sym_for_stmt) +!!$ +!!$ if(pm_is_compiling) then +!!$ ! Call PM__do_over to set-up subset loops +!!$ call make_sys_var(coder,cblock3,node,sym_nested_loop,var_is_shadowed) +!!$ call dup_code(coder) +!!$ call code_val(coder,coder%var(coder%over_base)) +!!$ call code_val(coder,coder%var(iter+lv_distr)) +!!$ call make_basic_sys_call(coder,cblock3,node,sym_do_over,2,1,& +!!$ coder%par_depth-1,call_inline_when_compiling) +!!$ call make_basic_sys_call(coder,cblock3,node,sym_nested_loop,1,0,& +!!$ coder%par_depth-1,call_inline_when_compiling) +!!$ endif end subroutine code_loop_startup subroutine code_loop_finish(cblock,cblock2,cblock3) type(pm_ptr),intent(in):: cblock,cblock2,cblock3 - call close_cblock(coder,cblock3) - call make_sp_call(coder,cblock2,node,sym_for,1,0) - call close_cblock(coder,cblock2) - call pop_par_scope(coder,cblock,node) - call code_val(coder,coder%var(coder%par_base+lv_numz)) - call code_val(coder,cblock2) - call code_val(coder,coder%var(coder%par_base+lv_num)) - call make_sp_call(coder,cblock,node,sym_pct,2,1) +!!$ call close_cblock(coder,cblock3) +!!$ call make_sp_call(coder,cblock2,node,sym_for,1,0) +!!$ call close_cblock(coder,cblock2) +!!$ call pop_par_scope(coder,cblock,node) +!!$ call code_val(coder,coder%var(coder%par_base+lv_numz)) +!!$ call code_val(coder,cblock2) +!!$ call code_val(coder,coder%var(coder%par_base+lv_num)) +!!$ call make_sp_call(coder,cblock,node,sym_pct,2,1) end subroutine code_loop_finish - recursive subroutine code_proc_each - integer:: cflags - type(pm_ptr):: cblock5,cblock6,arg1 - integer:: slot1 - loop_pars=coder%top - call code_params(cblock,iand(flags,proc_is_comm)/=0) - call code_keys(cblock,tkeys) - base=coder%vtop - do i=1,nret - call make_temp_var(coder,cblock,node) - enddo - cblock3=make_cblock(coder,cblock,node,sym_each) - if(nret>0) then - do i=1,nret - call code_val(coder,coder%vstack(base+i)) - enddo - call make_sp_call(coder,cblock3,node,sym_result,nret,0) - endif - call close_cblock(coder,cblock3) - cblock2=make_cblock(coder,cblock,node,sym_each) - slot1=coder%index+1 - if(iand(flags,proc_is_comm)==0) then - if(debug_codegen) then - write(*,*) 'TRAV EACH PROC>',& - trim(pm_name_as_string(coder%context,& - node_get_num(node,proc_name))),coder%wtop,coder%proc_base - endif - call code_body(cblock2) - call code_result(cblock2,flags) - ! Flag special cases: f(x) each(x)=x; f(x) each(x) {}; PM__dup() - pr_flags=proc_is_each_proc - if(npars==1.and.nret==1) then - if(pm_fast_isnull(node_get(node,proc_stmts))) then - arg1=node_arg(node_get(node,proc_params),1) - if(arg1%offset==sym_dup) then - pr_flags=pr_flags+proc_is_dup_each - elseif(arg1==node_arg(node_get(node,proc_result),1)) then - pr_flags=pr_flags+proc_is_thru_each - endif - endif - elseif(nret==0) then - if(node_numargs(node_get(node,proc_stmts))==0) then - pr_flags=pr_flags+proc_is_empty_each - endif - endif - else - call code_loop_startup(cblock2,cblock4,cblock5) - call code_check(cblock5) - call code_body(cblock5) - call code_result(cblock5,flags) - call code_loop_finish(cblock2,cblock4,cblock5) - pr_flags=proc_is_each_proc+proc_is_comm - endif - call close_cblock(coder,cblock2) - cblock4=make_cblock(coder,cblock,node,sym_each) - coder%temp=pm_fast_newnc(coder%context,& - pm_int,2) - rv=coder%temp - call make_const(coder,cblock,node,coder%temp) - rv%data%i(rv%offset)=slot1 - p=node_get(node,proc_reduce) - n=node_numargs(p) - do i=1,n - par=node_arg(p,i) - arg=find_var(coder,node_arg(p,i)) - if(pm_fast_isnull(arg)) then - call code_error(coder,p,& - '"each" variable not in parameter list',par) - elseif(cnode_flags_clear(arg,var_flags,var_is_param)) then - call code_error(coder,p,& - 'repeated "each" variable') - endif - call code_val(coder,arg) - call make_var(coder,cblock,node,node_arg(p,i),var_is_shadowed) - enddo - base=coder%vtop - do i=1,nret - call make_temp_var(coder,cblock,node) - enddo - if(sym/=sym_proc) then - call code_loop_startup(cblock4,cblock5,cblock6) - else - cblock6=cblock4 - endif - do i=1,nret - call code_val(coder,coder%vstack(base+i)) - enddo - if(nkeyargs>0) then - do i=1,nkeyargs - call make_temp_var(coder,cblock6,node) - call dup_code(coder) - call make_int_const(coder,cblock6,& - node,i+nret) - call make_sp_call(coder,cblock6,& - node,sym_key,1,1) - enddo - endif - p=node_get(node,proc_params) - do i=1,node_numargs(p),2 - call code_val(coder,find_var(coder,node_arg(p,i))) - enddo - if(sym==sym_pct) then - cflags=call_is_comm - else - cflags=0 - endif - call make_full_call(coder,cblock6,node,procs,amplocs,npars,& - nret,nkeyargs,cflags,pm_null_obj,coder%par_depth) - if(sym/=sym_proc) then - call code_loop_finish(cblock4,cblock5,cblock6) - endif - call close_cblock(coder,cblock4) - rv%data%i(rv%offset+1)=coder%index - call make_sp_call(coder,cblock,node,sym_each_proc,4+nret+n*2,nret) - end subroutine code_proc_each - end subroutine trav_proc @@ -6711,7 +5314,13 @@ subroutine proc_const(coder,cblock,pnode,pr) type(pm_ptr):: p integer(pm_ln):: m logical:: ok - p=find_decl(coder,pnode,pr,modl_proc) + + if(node_numargs(pr)==1) then + p=find_decl(coder,pnode,node_arg(pr,1),modl_proc) + else + p=find_imported_decl(coder,pnode,& + node_arg(pr,1),node_arg(pr,2),modl_proc) + endif if(pm_fast_isnull(p)) then call code_error(coder,pnode,& 'proc value not associated with any defined procedure: ',pr) @@ -6729,14 +5338,13 @@ end subroutine proc_const subroutine proc_const_from_decl(coder,cblock,node,p) type(code_state):: coder type(pm_ptr),intent(in):: cblock,node,p - type(pm_ptr):: namep + type(pm_ptr):: namep,sig logical:: ok integer(pm_ln):: m namep=node_get(p,proc_name) call make_const(coder,cblock,node,namep,& proc_type_from_decl(coder,p,node)) - call pm_dict_set(coder%context,coder%proc_name_vals,& - namep,p,.true.,.true.,ok,m) + sig=find_sig(coder,node,namep,p) end subroutine proc_const_from_decl !======================================================== @@ -6817,9 +5425,6 @@ function proc_param_type(coder,node) result(tno) type(pm_ptr):: p,amp,arg integer:: i,n - tno=node_get_num(node,proc_coded_params) - if(tno>0) return - p=node_get(node,proc_params) call push_word(coder,merge(pm_type_is_vtuple,pm_type_is_tuple,& node_sym(p)==sym_dotdotdot)) @@ -6837,7 +5442,6 @@ function proc_param_type(coder,node) result(tno) call make_type(coder,n/2+2) tno=pop_word(coder) - call node_set_num(node,proc_coded_params,tno) contains include 'fisnull.inc' end function proc_param_type @@ -6851,8 +5455,7 @@ function proc_result_type(coder,node) result(tno) integer:: tno integer:: nret,i type(pm_ptr):: p,arg - tno=node_get_num(node,proc_coded_results) - if(tno>0) return + p=node_get(node,proc_result_types) if(node_sym(node)==sym_builtin.and.node_sym(p)==sym_dash) then p=node_arg(p,1) @@ -6881,420 +5484,74 @@ function proc_result_type(coder,node) result(tno) call make_type(coder,nret+2) endif tno=pop_word(coder) - call node_set_num(node,proc_coded_results,tno) contains include 'fisnull.inc' end function proc_result_type - - !======================================================== - ! Find of construct procedure signature - !======================================================== - recursive function find_sig(coder,node,pname,amplocs,& - nargs,nret,flags,sigvect,iscomm,noerr,procroot) result(sig) + recursive function find_sig(coder,node,pname,pdef) result(sig) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node,pname,amplocs - integer,intent(in):: nargs,nret,flags - type(pm_ptr),intent(out):: sigvect - logical,intent(in):: iscomm - logical,optional,intent(in):: noerr - type(pm_ptr),optional,intent(in):: procroot - type(pm_ptr):: sig,name,modl,xproc,arg - type(pm_ptr):: cblock,keys, procdef,proc,amplocs2,keyargs, cproc - integer:: nret2,nargs2,base,i,j,n,oldwtop,numprocs,lclbase - integer:: k,oldk - integer:: flags2,owtop,sigflags,siglen - logical:: vkeys - character(len=100):: str - owtop=coder%wtop - lclbase=-1 - if(iscomm) then - lclbase=coder%wtop - do i=1,nargs - arg=coder%vstack(coder%vtop-nargs+i) - if(cnode_get_kind(arg)==cnode_is_var) then - coder%wstack(coder%wtop+i)=& - merge(var_is_imported,0,par_depth(coder,arg)',& - pm_fast_isnull(node_get(proc,proc_link)) - endif - if(proc_conforms()) then - if(debug_codegen) then - write(*,*) 'CONFORMING_PROC>',coder%vtop,base,trim(str) - endif - call trav_proc(coder,node,proc,nargs,keys,& - amplocs,nret,sig,numprocs,lclbase) - if(coder%wtop/=oldwtop) call pm_panic('stray w') - if(debug_codegen) then - write(*,*) 'FINISHED TRAVERSING CONFORMING PROC>',& - coder%vtop,base,trim(str) - endif - cproc=top_code(coder) - if(cnode_get_kind(cproc)==cnode_is_builtin) then - flags2=cnode_get_num(cproc,bi_flags) - else - flags2=cnode_get_num(cproc,pr_flags) - endif - ! Combine flags for this signature - coder%vstack(base+2)%offset=& - ior(coder%vstack(base+2)%offset,& - int(flags2,pm_p)) - endif - proc=node_get(proc,proc_link) - if(pm_fast_isnull(proc)) exit - enddo - if(.not.pm_fast_isnull(keys)) then - n=pm_set_size(coder%context,keys) - do i=base+4,coder%vtop,2 - if(cnode_get_kind(coder%vstack(i))==cnode_is_proc) then - call cnode_set_num(coder%vstack(i),pr_nkeys,n) - endif - enddo - endif - if(debug_codegen) then - write(*,*) 'SIGEND> ',& - 'NARGS=',nargs,'nret=',nret,'N=',& - coder%vtop-base,'WT=',coder%wtop - endif - if(coder%vtop>base+2) then - if(debug_codegen) & - write(*,*) 'MAKE-SIG-VECT>',base,coder%vtop,coder%vtop-base - call make_code(coder,node,cnode_is_arglist,coder%vtop-base) - sig=top_code(coder) - k=pm_idict_add(coder%context,coder%sig_cache,& - coder%wstack(coder%wtop-siglen+1:),siglen,sig) - if(k/=oldk) then - write(*,*) k,oldk,oldwtop - call pm_panic('k moved') - endif - call drop_code(coder) - sigvect=sig - sig=pm_fast_tinyint(coder%context,k) - else - call drop_code(coder) - call drop_code(coder) - if(.not.present(noerr)) then - call code_error(coder,node,& - 'Cannot find procedure with compatable signature: ') - call more_error(coder%context,& - ' '//trim(sig_as_str(coder,name,amplocs,& - nargs,nret,flags))) - proc=node_arg(procdef,2) - call more_error(coder%context,& - ' Procedures considered:') - i=0 - do - call more_error(coder%context,& - ' '//trim(proc_sig_as_str(coder,proc))) - proc=node_get(proc,proc_link) - if(pm_fast_isnull(proc)) exit - i=i+1 - if(i>11.and..not.pm_opts%see_all_procs) then - call more_error(coder%context,'... (to see all procedures use -fsee-all-procs)') - exit - endif - enddo - endif - sig=pm_null_obj - endif - else - sig=pm_fast_tinyint(coder%context,k) - sigvect=pm_dict_val(coder%context,coder%sig_cache,int(k,pm_ln)) - endif - coder%wtop=owtop - contains - include 'fisnull.inc' - include 'fnewnc.inc' - include 'ftiny.inc' - - function proc_conforms() result(ok) - logical:: ok - type(pm_ptr):: params,arg - integer:: sym,flags2 - amplocs2=node_get(proc,proc_amplocs) - nret2=node_get_num(proc,proc_numret) - flags2=node_get_num(proc,proc_flags) - if(debug_codegen) then - write(*,*) 'CHECK CONFORM>',& - amplocs%offset,amplocs2%offset,& - nret,nret2,flags,flags2 - endif - ok=(iand(flags,call_is_comm)==& - iand(flags2,proc_is_comm)& - .and.amplocs2%offset==amplocs%offset& - .and.nret2==nret) - if(iand(flags2,proc_is_cond+proc_is_uncond)/=0) then - if(iand(flags2,proc_is_cond)/=0) then - if(coder%par_state=par_state_cond) ok=.false. - endif - endif - end function proc_conforms - - end function find_sig - - !====================================================================== - ! Find or construct signature for variable call using variable selector - !====================================================================== - recursive function find_vcall_sig(coder,node,amplocs,& - nargs,nret,flags,sigvect,iscomm) result(sig) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node,amplocs - integer,intent(in):: nargs,nret,flags - type(pm_ptr),intent(out):: sigvect - logical,intent(in):: iscomm - type(pm_ptr):: sig,arg - integer:: k - integer:: i,cflags,flags2,locl_base,siglen - character(len=100):: str - siglen=4 - if(iscomm) then - do i=1,nargs - arg=coder%vstack(coder%vtop-nargs+i) - if(cnode_get_kind(arg)==cnode_is_var) then - coder%wstack(coder%wtop+i)=cnode_get_num(arg,var_flags) - else - coder%wstack(coder%wtop+i)=0 - endif - enddo - coder%wtop=coder%wtop+nargs - siglen=siglen+nargs - end if - call check_wstack(coder,4) - coder%wstack(coder%wtop+1)=iand(flags,call_is_comm) - coder%wstack(coder%wtop+2)=amplocs%offset - coder%wstack(coder%wtop+3)=nret - coder%wstack(coder%wtop+4)=sym_proc - coder%wtop=coder%wtop+4 - k=pm_ivect_lookup(coder%context,coder%sig_cache,& - coder%wstack(coder%wtop-siglen+1:),siglen) - if(k>0) then - sig=pm_fast_tinyint(coder%context,k) - sigvect=pm_dict_val(coder%context,& - coder%sig_cache,int(k,pm_ln)) - else - call code_null(coder) - call code_num(coder,proc_is_var) - call code_num(coder,coder%call_sig) - call code_val(coder,node) - call make_code(coder,node,cnode_is_arglist,4) - sigvect=top_code(coder) - k=pm_idict_add(coder%context,& - coder%sig_cache,& - coder%wstack(coder%wtop-siglen+1:),& - siglen,sigvect) - coder%call_sig=k - - sig=pm_fast_tinyint(coder%context,k) - call drop_code(coder) - - endif - coder%wtop=coder%wtop-siglen - contains - include 'ftiny.inc' - end function find_vcall_sig - - !======================================================================= - ! Complete variable-call signatures now all proc{..} values located - !======================================================================= - subroutine complete_vcall_sigs(coder) - type(code_state):: coder - integer(pm_ln):: kbase,k,newk,nbase - type(pm_ptr):: name,names,nameset,amplocs,key,keys - type(pm_ptr):: sig,vals,val,node,sigvect,procroot,procroots - integer:: i,nret,nargs,base,n,lbase,flags - k=coder%call_sig - if(k==0) return - - if(pm_fast_isnull(coder%proc_name_vals)) then - val=vals%data%ptr(vals%offset+k-1) - call cnode_error(coder,val,& - 'Call to procedure value '//& - ' but program does not create any procedure values') + + args(1)=node_get_num(procdef,proc_name) + signo=pm_ivect_lookup(coder%context,coder%sig_cache,& + args,1) + if(signo>0) then + sig=pm_fast_tinyint(coder%context,signo) return endif + + call make_code(coder,node,cnode_is_callsig,0) + signo=pm_idict_add(coder%context,coder%sig_cache,& + args,1,pop_code(coder)) + + base=coder%vtop + proc=node_arg(procdef,2) do - k=coder%call_sig - kbase=k - nameset=coder%proc_name_vals - nbase=pm_dict_size(coder%context,nameset) - names=pm_dict_keys(coder%context,nameset) - procroots=pm_dict_vals(coder%context,nameset) - keys=pm_dict_keys(coder%context,coder%sig_cache) - vals=pm_dict_vals(coder%context,coder%sig_cache) - do while(k/=0) - key=keys%data%ptr(keys%offset+k-1) - val=vals%data%ptr(vals%offset+k-1) - node=cnode_arg(val,4) - n=pm_fast_esize(key) - flags=key%data%i(key%offset+n-3) - nargs=n-4 - amplocs=pm_fast_name(coder%context,& - key%data%i(key%offset+n-2)) - nret=key%data%i(key%offset+n-1) - base=coder%vtop - lbase=coder%wtop - call check_wstack(coder,int(pm_fast_esize(key)-2)) - coder%wstack(coder%wtop+1:coder%wtop+pm_fast_esize(key)-3)=& - key%data%i(key%offset:key%offset+pm_fast_esize(key)-4) - coder%wtop=coder%wtop+pm_fast_esize(key)-3 - call code_null(coder) - call code_val(coder,cnode_arg(val,2)) - call code_val(coder,cnode_arg(val,3)) - call code_val(coder,cnode_arg(val,4)) - do i=1,pm_dict_size(coder%context,nameset) - procroot=procroots%data%ptr(procroots%offset+i-1) - name=names%data%ptr(names%offset+i-1) - sig=find_sig(coder,node,name,amplocs,& - nargs,nret,flags,sigvect,.false.,& - noerr=.true.,procroot=procroot) - if(.not.pm_fast_isnull(sig)) then - call code_val(coder,name) - call code_val(coder,sig) - endif - enddo - coder%wtop=lbase - newk=cnode_num_arg(val,3) - call make_code(coder,node,cnode_is_arglist,& - coder%vtop-base) - call pm_dict_set_val(coder%context,& - coder%sig_cache,k,top_code(coder)) - call drop_code(coder) - coder%vtop=base - k=newk - enddo - if(nbase==pm_dict_size(coder%context,coder%proc_name_vals).and.& - kbase==coder%call_sig) exit + call trav_proc(coder,proc) + proc=node_get(proc,proc_link) + if(pm_fast_isnull(proc)) exit enddo + call make_code(coder,node,cnode_is_callsig,coder%vtop-base) + signo=pm_idict_add(coder%context,coder%sig_cache,& + args,1,top_code(coder)) + call drop_code(coder) + sig=pm_fast_tinyint(coder%context,signo) contains - include 'fname.inc' include 'fisnull.inc' - include 'fesize.inc' - end subroutine complete_vcall_sigs - + include 'ftiny.inc' + end function find_sig + !=========================================== ! Sort all defined signatures !=========================================== subroutine sort_sigs(coder) type(code_state),intent(inout):: coder integer(pm_ln):: i - type(pm_ptr):: vals,v,n + type(pm_ptr):: vals,v if(debug_codegen) then - write(*,*) 'SORT SIGS',pm_dict_size(coder%context,coder%sig_cache) + write(*,*) 'SORT SIGS',& + pm_dict_size(coder%context,coder%sig_cache) endif vals=pm_dict_vals(coder%context,coder%sig_cache) do i=0,pm_dict_size(coder%context,coder%sig_cache)-1 v=vals%data%ptr(vals%offset+i) - if(cnode_flags_clear(v,cnode_args+1,proc_is_var)) then - if(debug_codegen) then - write(*,*) 'SORT SIG',i,& - pm_dict_size(coder%context,coder%sig_cache)-1,& - trim(sig_name_str(coder,int(i+1))),& - v%data%ptr(v%offset+cnode_args+1)%offset - endif - call sort_sig(coder,v,int(i+1)) - else if(debug_codegen) then - write(*,*) 'SORT SIG SKIP',i,& - pm_dict_size(coder%context,coder%sig_cache)-1,& - trim(sig_name_str(coder,int(i+1))) - endif + call sort_sig(coder,v,int(i+1)) enddo end subroutine sort_sigs @@ -7305,22 +5562,21 @@ subroutine sort_sig(coder,sig,signo) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: sig integer,intent(in):: signo - integer:: start,end - integer:: h,i,j,k,ii,rel,rtype1,rtype2 - integer:: typ1,typ2,typ3,inter,union - type(pm_ptr):: code,pars + integer:: i,j,typ1,typ2 + type(pm_ptr):: proc1,proc2 logical:: ok type(pm_type_einfo):: einfo - start=sig%offset+cnode_args+2 - end=sig%offset+pm_fast_esize(sig) - if(debug_codegen) write(*,*) 'SORT SIGNATURE>',start,end - do i=end-3,start,-2 - if(debug_more_codegen) write(*,*) 'I=',i,i+2,end-1 - typ1=sig%data%ptr(i)%offset - code=sig%data%ptr(i+1) - j=i+2 - do while(j<=end-1) - typ2=sig%data%ptr(j)%offset + + if(debug_codegen) write(*,*) 'SORT SIGNATURE>' + + do i=cnode_numargs(sig),1,-1 + proc1=cnode_arg(sig,i) + typ1=cnode_get_num(proc1,pr_ptype) + j=i+1 + do while(j<=cnode_numargs(sig)) + proc2=cnode_arg(sig,j) + typ2=cnode_get_num(proc2,pr_ptype) + if(debug_codegen) then write(*,*) 'COMPARE SIGS>',typ1,typ2 write(*,*) '--------------------------------------' @@ -7328,8 +5584,14 @@ subroutine sort_sig(coder,sig,signo) write(*,*) trim(pm_type_as_string(coder%context,typ1)) write(*,*) '--------------------------------------' endif - if(typ1==typ2) then - call cnode_error(coder,code,& + if(cnode_get_num(proc1,pr_nret)/=cnode_get_num(proc2,pr_nret).or.& + iand(cnode_get_num(proc1,pr_flags),proc_is_comm+proc_is_cond)/=& + iand(cnode_get_num(proc2,pr_flags),proc_is_comm+proc_is_cond)) then + if(debug_more_codegen) write(*,*) 'SIG DIFFERENT' + sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 + j=j+1 + else if(typ1==typ2) then + call cnode_error(coder,proc1,& 'Procedure "'//trim(sig_name_str(coder,signo))//& '" defined with identical signatures:'//& trim(pm_type_as_string(coder%context,typ2))) @@ -7338,55 +5600,33 @@ subroutine sort_sig(coder,sig,signo) return else if(pm_type_includes(coder%context,typ2,typ1,pm_type_incl_type,& einfo)) then - if(debug_more_codegen) write(*,*) 'INCL' - call check_nesting(code,sig%data%ptr(j+1)) + if(debug_more_codegen) write(*,*) 'SIG INCL' + call check_nesting(proc1,proc2) exit else - if(debug_more_codegen) write(*,*) 'NOT INCL' + if(debug_more_codegen) write(*,*) 'SIG NOT INCL' if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type,& einfo)) then - call check_nesting(sig%data%ptr(j+1),code) + call check_nesting(proc2,proc1) endif - sig%data%ptr(j-2)=sig%data%ptr(j) - sig%data%ptr(j-1)=sig%data%ptr(j+1) - j=j+2 + sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 + j=j+1 endif enddo - sig%data%ptr(j-2)%offset=typ1 - sig%data%ptr(j-1)=code + sig%data%ptr(sig%offset+cnode_args+j-2)=proc1 enddo - - - if(pm_debug_checks) then - do i=start,end-1,2 - !write(*,*) '::',i,sig%data%ptr(i+1)%data%vkind - if(sig%data%ptr(i+1)%data%vkind/=pm_pointer) then - call pm_dump_tree(coder%context,6,sig%data%ptr(i+1),2) - !write(*,*) sym_names(sig%data%ptr(i+1)%offset) - else - !call qqdump_code_tree(coder,pm_null_obj,6,sig%data%ptr(i+1),2) - endif - if(cnode_get_kind(sig%data%ptr(i+1))/=cnode_is_proc& - .and.cnode_get_kind(sig%data%ptr(i+1))/=cnode_is_builtin) then - write(*,*) cnode_get_kind(sig%data%ptr(i+1)) - call pm_panic('sort_sig not proc') - endif - end do - end if + contains include 'fesize.inc' subroutine check_nesting(first,second) type(pm_ptr),intent(in):: first,second logical:: isbad - integer:: ret1,ret2 + integer:: ret1,ret2,rtype1,rtype2,ii type(pm_ptr):: tv1,tv2 if(cnode_flags_clear(second,& pr_flags,proc_is_open)) then -!!$ write(*,*) 'COMPARE>',trim(sig_name_str(coder,signo)),' ',& -!!$ trim(pm_name_as_string(coder%context,cnode_get_name(code,cnode_modl_name))),& -!!$ trim(pm_name_as_string(coder%context,cnode_get_name(sig%data%ptr(j+1),cnode_modl_name))) if(.not.(cnode_get(first,cnode_modl_name)==& cnode_get(second,cnode_modl_name))) then call cnode_error(coder,first,& @@ -7396,22 +5636,6 @@ subroutine check_nesting(first,second) endif endif - ! This would implement the ".." internal-to-module extension - ! rule - not yet decided if this is a good idea - -!!$ if(cnode_flags_clear(sig%data%ptr(j+1),& -!!$ pr_flags,proc_is_extensible)) then -!!$ call cnode_error(coder,code,& -!!$ 'Procedure "'//trim(sig_name_str(coder,signo))//& -!!$ '" attempts to specialise procedure defined without ".." or "..."') -!!$ call cnode_error(coder,sig%data%ptr(j+1),& -!!$ 'Conflicting definition') -!!$ endif - - ! This assumes pr_rtype == bi_rtype - if(pm_debug_checks) then - if(pr_rtype/=bi_rtype) call pm_panic('pr_rtype/=bi_rtype') - endif ret1=cnode_get_num(second,pr_rtype) ret2=cnode_get_num(first,pr_rtype) tv1=pm_type_vect(coder%context,ret1) @@ -7437,8 +5661,7 @@ subroutine check_nesting(first,second) 'but in this procedure has type: '//& trim(pm_type_as_string(coder%context,rtype2))) isbad=.true. - - + endif enddo if(isbad) then @@ -7804,7 +6027,7 @@ subroutine make_temp_var(coder,cblock,node) pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) call code_val(coder,& pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) - call code_num(coder,coder%if_scope) + call code_num(coder,coder%lex_scope) call make_code(coder,node,cnode_is_var,var_node_size) link=cnode_get(cblock,cblock_last_var) if(pm_fast_isnull(link)) then @@ -7896,7 +6119,7 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) coder%par_depth-coder%proc_par_depth)) call code_val(coder,pm_fast_tinyint(coder%context,& coder%par_depth-coder%proc_par_depth)) - call code_num(coder,coder%if_scope) + call code_num(coder,coder%lex_scope) if(present(extra_info)) then call code_val(coder,extra_info) call make_code(coder,node,cnode_is_var,var_node_size+1) @@ -7959,12 +6182,24 @@ subroutine pop_vars_to(coder,newbase) old_top=coder%top coder%top=newbase do i=newbase+1,old_top +!!$ if(cnode_flags_clear(coder%var(i),var_flags,var_is_accessed+var_is_changed)) then +!!$ call cnode_error(coder,coder%var(i),'Variable is defined but never used: ',& +!!$ cnode_get(coder%var(i),var_name)) +!!$ endif if(coder%imps(i)/=0) then if(coder%imps(i)<=coder%par_depth) then + ! Keep imports to current parallel scope coder%top=coder%top+1 coder%imps(coder%top)=coder%imps(i) coder%stack(coder%top)=coder%stack(i) coder%var(coder%top)=coder%var(i) + elseif(par_depth(coder,coder%var(i))=par_state_cond.and.& - iand(flags,proc_run_complete+proc_run_shared+proc_run_local)==0) then - flags=ior(flags,call_is_cond) - endif - call import_args(coder,cblock,node,narg,nret,0,avec,flags,base) + call make_arglist(coder,cblock,node,nargs,nret,.false.) + call code_null(coder) procs=find_sig(coder,node,& - pm_fast_name(coder%context,sym),& - avec,narg,nret,flags,svect,.false.) + pm_fast_name(coder%context,sym)) call make_full_call(coder,cblock,node,& - procs,avec,narg,nret,0,flags,pm_null_obj,coder%par_depth) + procs,avec,nargs,abs(nret),0,pm_null_obj,flags,pm_null_obj,coder%par_depth) contains include 'fname.inc' end subroutine make_sys_call + !============================================= + ! Make a call to an intrinsic procedure + ! Arguments must be on vstack + ! Temporary return variables created and left + ! on the vstack + !============================================= + subroutine make_sys_call_rtn(coder,cblock,node,sym,& + nargs,nret,aflags,assign) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: sym,nargs,nret + integer,intent(in),optional:: aflags + logical,intent(in),optional:: assign + call make_sys_call(coder,cblock,node,sym,& + nargs,-nret,aflags,assign) + end subroutine make_sys_call_rtn + !====================================================== ! Make a call to an intrinsic communicating procedure + ! Returns precede arguments on the stack !====================================================== subroutine make_comm_sys_call(coder,cblock,node,sym,& nargs,nret,aflags,assign) @@ -8187,31 +6452,50 @@ subroutine make_comm_sys_call(coder,cblock,node,sym,& else avec=pm_null_obj endif - call import_args(coder,cblock,node,narg,nret,0,avec,flags,base) procs=find_sig(coder,node,& - pm_fast_name(coder%context,sym)& - ,avec,narg,nret,flags,svect,.true.) + pm_fast_name(coder%context,sym)) + call make_arglist(coder,cblock,node,nargs,nret,.true.) + call code_null(coder) call make_full_call(coder,cblock,node,& - procs,avec,narg,nret,0,flags,pm_null_obj,coder%par_depth) + procs,avec,narg,abs(nret),0,pm_null_obj,flags,pm_null_obj,coder%par_depth) contains include 'fname.inc' end subroutine make_comm_sys_call + !============================================= + ! Make a call to a communicating procedure + ! Arguments must be on vstack + ! Temporary return variables created and left + ! on the vstack + !============================================= + subroutine make_comm_sys_call_rtn(coder,cblock,node,sym,& + nargs,nret,aflags,assign) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: sym,nargs,nret + integer,intent(in),optional:: aflags + logical,intent(in),optional:: assign + call make_comm_sys_call(coder,cblock,node,sym,& + nargs,-nret,aflags,assign) + end subroutine make_comm_sys_call_rtn + !==================================================================== ! Make a call to an intrinsic procedure with & on first argument + ! Returns must precede arguments on the stack !==================================================================== - subroutine make_assign_call(coder,cblock,node,sym,narg,nret,aflags) + subroutine make_assign_call(coder,cblock,node,sym,nargs,nret,aflags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret + integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: aflags - call make_sys_call(coder,cblock,node,sym,narg,nret,& + call make_sys_call(coder,cblock,node,sym,nargs,nret,& aflags=aflags,assign=.true.) end subroutine make_assign_call !================================================= ! Make a call to an intrinsic procedure ! with no processing of imports/exports + ! Returns must precede arguments on the stack !================================================= subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,depth,flags) type(code_state),intent(inout):: coder @@ -8219,70 +6503,48 @@ subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,depth,flags) integer,intent(in):: sym,narg,nret,depth,flags type(pm_ptr):: procs,svect procs=find_sig(coder,node,& - pm_fast_name(coder%context,sym),& - pm_null_obj,narg,nret,0,svect,.false.) + pm_fast_name(coder%context,sym)) + call make_arglist(coder,cblock,node,narg,nret,.false.,.true.) + call code_null(coder) call make_full_call(coder,cblock,node,& - procs,pm_null_obj,narg,nret,0,ior(flags,coder%run_flags),pm_null_obj,depth) + procs,pm_null_obj,narg,abs(nret),0,pm_null_obj,& + ior(flags,coder%run_flags),pm_null_obj,depth) contains include 'fname.inc' end subroutine make_basic_sys_call !========================================== ! Make a procedure call + ! Argument list and key argument list (or null) + ! must be on top of vstack. !========================================== subroutine make_full_call(coder,cblock,node,procs,& - amp,narg,nret,nkeys,iflag,var,depth) + amps,nargs,nret,nkeys,keynames,iflag,var,depth) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,procs,amp,var - integer,intent(in):: narg,nret,nkeys - integer,intent(in):: iflag,depth - type(pm_ptr):: p,q,n,args + type(pm_ptr),intent(in):: cblock,node,procs,amps,var,keynames + integer,intent(in):: nargs,nret,nkeys,iflag,depth + type(pm_ptr):: p,q,n,args,keys integer:: i if(pm_debug_checks) then - if(cnode_get_kind(cblock)/=cnode_is_cblock) & - call pm_panic('full call cblock') - endif - if(iand(iflag,proc_run_shared+proc_run_local+proc_run_complete+proc_run_always)/=0.and.& - iand(iflag,call_ignore_rules)==0) then - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot have "shared", "invar", "complete" or "<>" attribute'//& - ' outside of a parallel context') + if(cnode_get_kind(cblock)/=cnode_is_cblock) then + call pm_panic('full call cblock') endif endif - call make_code(coder,node,cnode_is_arglist,nret+nkeys+narg) - args=top_code(coder) call code_val(coder,cblock) call code_val(coder,procs) call code_num(coder,iflag) call code_null(coder) call code_val(coder,cnode_get(cblock,cblock_last_call)) call code_num(coder,nret) - call code_num(coder,nkeys) + call code_val(coder,keynames) coder%index=coder%index+1 call code_num(coder,coder%index) call code_num(coder,depth-coder%proc_par_depth) call code_val(coder,var) - call code_val(coder,amp) + call code_val(coder,amps) call make_code(coder,node,cnode_is_call,call_node_size) + n=top_code(coder) - if(iand(iflag,call_is_no_touch)==0) then - do i=nret+1,nret+nkeys+narg - p=cnode_arg(args,i) - if(pm_fast_vkind(p)==pm_pointer) then - if(cnode_get_kind(p)==cnode_is_var) then - if(cnode_flags_set(p,var_flags,var_is_accessed)) then - call cnode_set_flags(p,var_flags,var_is_multi_access) - else - call cnode_set_flags(p,var_flags,var_is_accessed) - endif - endif - endif - enddo - end if - do i=1,nret - p=cnode_arg(args,i) - enddo p=cnode_get(cblock,cblock_last_call) if(pm_fast_isnull(p)) then call pm_ptr_assign(coder%context,cblock,& @@ -8299,12 +6561,87 @@ subroutine make_full_call(coder,cblock,node,procs,& int(cblock_last_call,pm_ln),n) endif n=pop_code(coder) + + !write(*,*) '#nargs=',cnode_numargs(cnode_get(n,call_args)) + coder%proc_ncalls=coder%proc_ncalls+1 contains include 'fisnull.inc' include 'fvkind.inc' end subroutine make_full_call + !======================================================== + ! Make an argument list cnode on vstack + ! - list will contain returns, implicit args, arguments + ! in that order + ! - nargs arguments must be present at top of vstack + ! - if nret>0 then nret returns must precede arguments + ! - if nret<0 then nret temp variables created and left + ! on vstack before the argument list cnode + !======================================================== + subroutine make_arglist(coder,cblock,node,nargs,nret,iscomm,notouch) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: nargs,nret + logical,intent(in):: iscomm + logical,intent(in),optional:: notouch + integer:: i,ret0,arg0,extra0,nextra,base + type(pm_ptr):: arglist + + if(.not.present(notouch)) then + do i=coder%vtop-nargs+1,coder%vtop + call update_arg(coder%vstack(i)) + enddo + endif + arg0=coder%vtop-nargs + if(nret<0) then + base=arg0 + ret0=coder%vtop + do i=1,-nret + call make_temp_var(coder,cblock,node) + enddo + else + ret0=arg0-nret + base=ret0 + endif + + if(iscomm) then + extra0=coder%par_base + nextra=5 + else + extra0=coder%par_base+1 + nextra=0 + endif + arglist=make_arglist_cnode(coder,node,abs(nret),ret0,nextra,extra0,nargs,arg0) + if(nret<0.and.ret0>base) then + do i=1,-nret + coder%vstack(base+i)=coder%vstack(ret0+i) + enddo + coder%vtop=base-nret+1 + else + coder%vtop=base+1 + endif + coder%vstack(coder%vtop)=arglist + contains + include 'fvkind.inc' + + subroutine update_arg(p) + type(pm_ptr)::p +!!! check for chan and deref if required +!!! Check for block import + if(pm_fast_vkind(p)==pm_pointer) then + if(cnode_get_kind(p)==cnode_is_var) then + call update_change_lists(coder,p,.false.) + if(cnode_flags_set(p,var_flags,var_is_accessed)) then + call cnode_set_flags(p,var_flags,var_is_multi_access) + else + call cnode_set_flags(p,var_flags,var_is_accessed) + endif + endif + endif + end subroutine update_arg + end subroutine make_arglist + !================================= ! Make a cblock !================================= @@ -8358,10 +6695,55 @@ subroutine close_cblock(coder,cblock) include 'fisnull.inc' end subroutine close_cblock - !=============================== - ! Make a code tree node (cnode) - !=============================== + !=========================================================== + ! Make a code tree node (cnode) from nargs values on vstack + !=========================================================== subroutine make_code(coder,node,ckind,nargs) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + integer,intent(in):: ckind,nargs + integer:: i + call make_code_stem(coder,node,ckind,nargs) + coder%temp%data%ptr(coder%temp%offset+5:coder%temp%offset+4+nargs)=& + coder%vstack(coder%vtop-nargs+1:coder%vtop) + if(pm_debug_checks) then + do i=coder%temp%offset+5,coder%temp%offset+4+nargs + !write(*,*) ckind,'##', i-coder%temp%offset-cnode_args + call pm_verify_ptr(coder%temp%data%ptr(i),'Arg to new cnode') + enddo + endif + coder%vtop=coder%vtop-nargs+1 + coder%vstack(coder%vtop)=coder%temp + end subroutine make_code + + function make_arglist_cnode(coder,node,nret,ret0,nextra,extra0,nargs,args0) result(arglist) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + integer,intent(in):: nret,ret0,nextra,extra0,nargs,args0 + type(pm_ptr):: arglist + integer:: i,j,totargs + totargs=nret+nextra+nargs + !write(*,*) '####',nret,ret0,nextra,extra0,nargs,args0 + call make_code_stem(coder,node,cnode_is_arglist,totargs) + j=coder%temp%offset+5 + coder%temp%data%ptr(j:j+nret-1)=coder%vstack(ret0+1:ret0+nret) + j=j+nret + coder%temp%data%ptr(j:j+nextra-1)=coder%vstack(extra0+1:extra0+nextra) + j=j+nextra + coder%temp%data%ptr(j:j+nargs-1)=coder%vstack(args0+1:args0+nargs) + if(pm_debug_checks) then + if(j+nargs/=coder%temp%offset+5+totargs) call pm_panic('make_arglist') + do i=coder%temp%offset+5,coder%temp%offset+4+nargs + call pm_verify_ptr(coder%temp%data%ptr(i),'Arg to new cnode') + enddo + endif + arglist=coder%temp + end function make_arglist_cnode + + !====================================================================== + ! Make a code tree node (cnode) with unfilled space for nargs arguments + !====================================================================== + subroutine make_code_stem(coder,node,ckind,nargs) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: node integer,intent(in):: ckind,nargs @@ -8399,22 +6781,14 @@ subroutine make_code(coder,node,ckind,nargs) coder%temp%data%ptr(coder%temp%offset+3)=pm_null_obj coder%temp%data%ptr(coder%temp%offset+4)=pm_null_obj endif - coder%temp%data%ptr(coder%temp%offset+5:coder%temp%offset+4+nargs)=& - coder%vstack(coder%vtop-nargs+1:coder%vtop) - if(pm_debug_checks) then - do i=coder%temp%offset+5,coder%temp%offset+4+nargs - ! write(*,*) i-coder%temp%offset-3 - call pm_verify_ptr(coder%temp%data%ptr(i),'Arg to new cnode') - enddo - endif - coder%vtop=coder%vtop-nargs+1 - coder%vstack(coder%vtop)=coder%temp contains include 'fisnull.inc' include 'fnewnc.inc' include 'ftiny.inc' - end subroutine make_code + end subroutine make_code_stem + + !======================================= ! Check room on vstack !======================================= @@ -8777,16 +7151,11 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) (cnode_get_num(node,cnode_args)),& cnode_get_num(node,cnode_args+1),'(' endif - if(.not.pm_fast_isnull(cnode_get(node,bi_rcode))) then - call qdump_code_tree(coder,rvec,iunit,& - cnode_get(node,bi_rcode),depth+1) - endif write(iunit,*) spaces(1:depth*2),')' case(cnode_is_proc) write(iunit,'(A,A,i2,A,i2,A,i2,A,i3,A,i3,A)') spaces(1:depth*2),& 'Proc [nargs=',& - cnode_get_num(node,pr_nargs),',nkeys=',& - cnode_get_num(node,pr_nkeys),',nret=',cnode_get_num(node,pr_nret),& + cnode_get_num(node,pr_nargs),',nret=',cnode_get_num(node,pr_nret),& ',ncalls=',cnode_get_num(node,pr_ncalls),',flags=',cnode_get_num(node,pr_flags),'] (' if(cnode_flags_set(node,pr_flags,proc_is_comm)) & write(iunit,*) spaces(1:depth*2+1),'[loop]' @@ -9090,9 +7459,9 @@ subroutine code_error(coder,node,message,name,warn) if(.not.present(warn)) then if(present(name)) then call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//trim(message)//' '//trim(str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) else - str=trim(pm_opts%error)//message + str=trim(pm_opts%error)//' '//message endif write(*,'(A)') trim(str) else @@ -9129,9 +7498,9 @@ subroutine cnode_error(coder,node,message,name,warn) str=message elseif(present(name)) then call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//trim(message)//' '//trim(str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) else - str=trim(pm_opts%error)//trim(message) + str=trim(pm_opts%error)//' '//trim(message) endif write(*,'(A)') trim(str) endif diff --git a/src/deadcode.f90 b/src/deadcode.f90 index 27bd361..2529fc3 100644 --- a/src/deadcode.f90 +++ b/src/deadcode.f90 @@ -35,7 +35,6 @@ module pm_deadcode use pm_symbol use pm_types use pm_parser - use pm_sysdefs use pm_cnodes use pm_codegen implicit none diff --git a/src/infer.f90 b/src/infer.f90 index 12e72bf..e6a29d1 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -45,9 +45,9 @@ module pm_infer use pm_symbol use pm_types use pm_parser - use pm_sysdefs use pm_cnodes use pm_codegen + use pm_vmdefs implicit none ! Print compiler debugging messages @@ -77,6 +77,8 @@ module pm_infer integer,parameter:: par_mode_conc=4 integer,parameter:: par_mode_inner=5 + private:: get_var_type,get_arg_type + contains !============================================================ @@ -89,10 +91,10 @@ module pm_infer !============================== ! Type-infer main program !============================== - subroutine prc_prog(coder) + subroutine inf_prog(coder) type(code_state),intent(inout):: coder type(pm_ptr):: cnode - integer:: i,base + integer:: i if(debug_inference) write(*,*) 'PRC PROG>' @@ -112,12 +114,12 @@ subroutine prc_prog(coder) coder%taints=0 coder%proc_cache=pm_dict_new(coder%context,32_pm_ln) - + ! Setup resolution stack block - base=create_stack_frame(coder,0,coder%index,0) + call create_stack_frame(coder,0,coder%index,0) ! Process program code - call prc_cblock(coder,top_code(coder),3) + call inf_cblock(coder,top_code(coder)) ! Uncaught break implies infinite recursion if(coder%incomplete) then @@ -125,7 +127,7 @@ subroutine prc_prog(coder) call more_error(coder%context,& 'Error: A procedure in this program has infinite recursion') coder%flag_recursion=.true. - call prc_cblock(coder,top_code(coder),3) + call inf_cblock(coder,top_code(coder)) call pm_stop('Program contains infinite recursion') endif endif @@ -135,8 +137,8 @@ subroutine prc_prog(coder) enddo ! Create resolved code object - call code_int_vec(coder,coder%stack,3,coder%top) - call code_num(coder,coder%stack(1)) + call code_int_vec(coder,coder%stack,coder%base,coder%top) + call code_num(coder,coder%stack(2)) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) if(debug_inference) write(*,*) 'END OF PROG> vtop=',coder%vtop @@ -144,50 +146,51 @@ subroutine prc_prog(coder) contains include 'fnewnc.inc' include 'ftiny.inc' - end subroutine prc_prog + end subroutine inf_prog ! ==================================================== ! Type-infer procedure ! Returns signature index as tiny int in on vstack ! ==================================================== - function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& - keynames,oldbase) result(rtype) + function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& + keynames,keybase,proc_nkeys) result(rtype) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: prc,callnode + type(pm_ptr),intent(in):: procnode,callnode integer,intent(in):: atype,ptype - integer,intent(in):: nret,nkeys + integer,intent(in):: nret,nkeys,keybase,proc_nkeys type(pm_ptr),intent(in):: keynames - integer,intent(in):: oldbase type(pm_ptr):: cnode,cac integer:: rtype integer:: at - integer,dimension(4+pm_max_args):: key - integer:: i,j,base,keysize + integer,dimension(4+proc_nkeys):: key + integer:: i,j,keysize,nk integer(pm_ln):: k logical:: save_redo_calls,save_incomplete integer:: taints,save_taints - integer:: keypartyp,keyargtyp - type(pm_ptr):: save_prc, keys + integer:: keypartyp,keyargtyp,last_key_index,sp_code + type(pm_ptr):: save_procnode, keys logical:: iscomm - + taints=0 if(pm_debug_checks) then - if(cnode_get_kind(prc)/=cnode_is_proc) then - call pm_panic('prc-proc prc not proc') + if(cnode_get_kind(procnode)/=cnode_is_proc) then + call pm_panic('procnode-proc procnode not proc') endif endif - if(cnode_flags_set(prc,pr_flags,proc_is_abstract)) then - call infer_error(coder,callnode,& + ! If this is an abstract proc then raise an error + if(cnode_flags_set(procnode,pr_flags,proc_is_abstract)) then + call inf_error(coder,callnode,& 'Abstract procedure needs to be implemented for the given argument list') - call infer_error(coder,prc,& + call inf_error(coder,procnode,& 'Abstract procedure definition referenced in the above error') - call infer_trace(coder) + call inf_trace(coder) rtype=error_type + return endif - iscomm=cnode_flags_set(prc,pr_flags,proc_is_comm) + iscomm=cnode_flags_set(procnode,pr_flags,proc_is_comm) ! Dictionary entries in coder%proc_cache: ! Key is proc and argument types and implicit par_kind @@ -195,143 +198,118 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& ! or (-1) sp_in_process in process of resolution ! or (-2) sp_recursive called recursively ! or (-3) sp_break breaking (or previously broke) out of inference - + ! Is this combination already cached? - key(1)=cnode_get_num(prc,pr_id) + key(1)=cnode_get_num(procnode,pr_id) key(2)=atype - keysize=4 - keys=cnode_get(prc,pr_tkeys) - if(.not.pm_fast_isnull(keys)) then - ! If there are type-constrained key args, need to add their types to - ! the cache key - do i=0,pm_fast_esize(keys),2 - j=keys%data%i(keys%offset+i) - key(5+i)=coder%wstack(coder%proc_key_base+j) - enddo - keysize=5+pm_fast_esize(keys) - endif - if(debug_inference) write(*,*) 'LOOKUP',coder%par_kind,coder%par_kind2 - if(iscomm) then - key(3)=coder%par_kind - key(4)=coder%par_kind2 - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) - else - key(3)=-1 - key(4)=-1 - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) - if(k==0) then - key(3)=coder%par_kind - key(4)=-1 - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) - endif + keysize=2 + + ! Process keyword arguments - they form part of the hash key + last_key_index=0 + if(proc_nkeys>0) then + keys=cnode_get(procnode,pr_keys) + last_key_index=keys%data%i(keys%offset+pm_fast_esize(keys)) + call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) + call inf_key_args(coder,callnode,procnode,atype,& + nkeys,keynames,keybase,key(3:),nk) + keysize=keysize+nk + elseif(nkeys>0) then + call inf_error(coder,callnode,& + 'Keyword arguments in call to procedure that does not take any') + call inf_error_with_trace(coder,procnode,& + 'Procedure definition corresponding to the above error') endif if(debug_inference) then - write(*,*) 'PRC PROC>',key(1),key(2),key(3),key(4),k,& + write(*,*) 'PRC PROC>',key(1),key(2),k,& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name))),& + cnode_get_name(procnode,pr_name))),& trim(pm_type_as_string(coder%context,atype)) endif + ! Lookup combination of proc, arg types and all key types + ! defined for the procedure (including defaults) + k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) + ! This combination already cached if(k>0) then cnode=pm_dict_val(coder%context,coder%proc_cache,k) + if(debug_inference) then write(*,*) 'FOUND',k,'-->',key(1:keysize) write(*,*) 'CACHED>',k,cnode%data%vkind,cnode%offset,& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name))),sp_sig_recursive,sp_sig_in_process + cnode_get_name(procnode,pr_name))),sp_sig_recursive,sp_sig_in_process endif - ! One of the special codes + ! One of the special in-progress codes if(pm_fast_istiny(cnode)) then - if(cnode%offset==sp_sig_break) then + sp_code=cnode%offset + if(sp_code==sp_sig_break) then goto 10 - elseif(cnode%offset==sp_sig_recursive) then + elseif(sp_code==sp_sig_recursive) then if(coder%flag_recursion) then - call infer_error(coder,prc,'Recursive call to: '//& + call inf_error(coder,procnode,'Recursive call to: '//& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name)))) - call infer_trace(coder) + cnode_get_name(procnode,pr_name)))) + call inf_trace(coder) coder%flag_recursion=.false. endif coder%incomplete=.true. rtype=error_type - elseif(cnode%offset==sp_sig_in_process) then + elseif(sp_code==sp_sig_in_process) then call pm_dict_set_val(coder%context,coder%proc_cache,& k,pm_fast_tinyint(coder%context,sp_sig_recursive)) - if(coder%flag_recursion) then - call infer_error(coder,prc,'Recursive call to: '//& + if(coder%flag_recursion) then + call inf_error(coder,procnode,'Recursive call to: '//& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name)))) - call infer_trace(coder) + cnode_get_name(procnode,pr_name)))) + call inf_trace(coder) coder%flag_recursion=.false. endif coder%incomplete=.true. rtype=error_type - elseif(cnode%offset<0) then + elseif(sp_code<0) then ! Another special sig rtype=atype - call code_num(coder,int(cnode%offset)) + call code_num(coder,int(sp_code)) else ! Return type - rtype=cnode%offset + rtype=sp_code if(debug_inference) write(*,*) 'CACHED RETURN>',rtype call code_num(coder,int(k)) endif - return - endif + else - ! Not a special code so have an inferred type - - ! Pass out taints - taints=cnode_num_arg(cnode,3) - coder%taints=ior(coder%taints,iand(taints,proc_taints)) - - ! If not quite complete need to run through again - if(iand(taints,proc_unfinished)/=0.and.& - coder%redo_calls.and..not.coder%flag_recursion) goto 10 - - ! Check keyword arguments - keys=cnode_arg(cnode,4) - do i=0,nkeys-1 - keyargtyp=coder%wstack(coder%proc_key_base+i+1) - keypartyp=keys%data%i(keys%offset+i) - if(keyargtyp/=keypartyp) then - if(keypartyp==pm_tiny_int) then - keys%data%i(keys%offset+i)=keyargtyp - elseif(keyargtyp/=pm_tiny_int) then - call infer_error(coder,prc,'Keyword/argument type mismatch:',& - pm_set_key(coder%context,keynames,int(i+1,pm_ln))) - call more_error(coder%context,'Mismatched argument: '//& - trim(pm_type_as_string(coder%context,keyargtyp))) - call more_error(coder%context,'Mismatched parameter: '//& - trim(pm_type_as_string(coder%context,keypartyp))) - call infer_trace(coder) - endif - endif - enddo + ! Not a special code so have a fully inferred procedure - ! Push signature - call code_num(coder,int(k)) - - ! Get return type - cnode=cnode_arg(cnode,2) - rtype=cnode%data%i(cnode%offset) - if(nret==0) rtype=0 - if(debug_inference) write(*,*) 'CACHED RTYPE>',rtype + ! Pass out taints + taints=cnode_num_arg(cnode,3) + coder%taints=ior(coder%taints,iand(taints,proc_taints)) + + ! Push signature + call code_num(coder,int(k)) + + ! Get return type + cnode=cnode_arg(cnode,2) + rtype=cnode%data%i(cnode%offset) + if(nret==0) rtype=0 + if(debug_inference) write(*,*) 'CACHED RTYPE>',rtype + endif + if(proc_nkeys>0) call pop_stack_frame(coder) return endif 10 continue - ! Proc is not (or not yet fully) inferred + ! Proc is not (or not yet fully) inferred at=atype - + ! Check for infinite recursion with changing arg types - if(cnode_get_num(prc,pr_recurse)>max_recur) then - call infer_error_with_trace(coder,prc,& + if(cnode_get_num(procnode,pr_recurse)>max_recur) then + call inf_error_with_trace(coder,procnode,& 'Recursion appears to require infinite types') call code_num(coder,0) return @@ -340,55 +318,57 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& 20 continue ! Flag call to check for recursion - call cnode_incr_num(prc,pr_recurse,1) + call cnode_incr_num(procnode,pr_recurse,1) k=pm_idict_add(coder%context,coder%proc_cache,& key,keysize,pm_fast_tinyint(coder%context,sp_sig_in_process)) ! Repeatedly type infer until complete save_incomplete=coder%incomplete save_taints=coder%taints + + if(proc_nkeys==0) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) do - if(debug_inference) write(*,*) 'TRY>',key(1),key(2),key(3),key(4),rtype + if(debug_inference) write(*,*) 'TRY>',key(1),key(2),rtype + + call init_stack_frame(coder,coder%base,last_key_index+1,coder%top,at,taints) - ! Create stack frame - base=create_stack_frame(coder,at,cnode_get_num(prc,pr_max_index),taints) - ! Process code coder%incomplete=.false. coder%taints=taints - save_prc=coder%proc - coder%proc=prc - call prc_cblock(coder,cnode_arg(prc,1),base) - coder%proc=save_prc + save_procnode=coder%proc + coder%proc=procnode + call inf_cblock(coder,cnode_get(procnode,pr_cblock)) + coder%proc=save_procnode ! Check procedure record for recursion/completion cnode=pm_dict_val(coder%context,coder%proc_cache,k) if(.not.pm_fast_istiny(cnode)) then write(*,*) cnode%data%vkind,k - call pm_panic('prc-proc bad cache') + call pm_panic('procnode-proc bad cache') endif - + if(debug_inference) then write(*,*) 'TRY COMPLETE>',cnode%offset,& - coder%stack(base),coder%stack(base-1),nret + coder%stack(coder%base),coder%stack(coder%base-1),nret endif - - if(cnode%offset==sp_sig_in_process) then + + sp_code=cnode%offset + if(sp_code==sp_sig_in_process) then ! Not recursively called - rtype=coder%stack(base) + rtype=coder%stack(coder%base) if(nret==0) rtype=0 if(debug_inference) write(*,*) 'NOT RECURSIVE>',rtype,coder%incomplete exit - else if(cnode%offset<=sp_sig_recursive) then + else if(sp_code<=sp_sig_recursive) then ! Recursively called - if(nret==0) coder%stack(base)=0 - - if(coder%stack(base)<0) then + if(nret==0) coder%stack(coder%base)=0 + + if(coder%stack(coder%base)<0) then ! No resolved type yet ! flag cache entry ! and break out - call pop_stack_frame(coder,base) - cnode%offset=sp_sig_break + call pop_stack_frame(coder) + sp_code=sp_sig_break call pm_dict_set_val(coder%context,& coder%proc_cache,k,cnode) coder%incomplete=.true. @@ -397,29 +377,31 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& if(debug_inference) write(*,*) 'NOT RESOLVED>' return endif - + ! Flag procedure as recursive coder%taints=ior(coder%taints,proc_is_recursive) - + ! Cache resolved return type - cnode%offset=coder%stack(base) + sp_code=coder%stack(coder%base) call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) else ! Recursive call for which we ! already have a return type ! check against type just returned - if(debug_inference) write(*,*) 'RT>',rtype,coder%stack(base) - rtype=cnode%offset + if(debug_inference) write(*,*) 'RT>',rtype,coder%stack(coder%base) + rtype=sp_code + + if(debug_inference) write(*,*) 'RECURSIVE WITH TYPE>',& + trim(pm_type_as_string(coder%context,rtype)),& + trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) - if(debug_inference) write(*,*) 'RECURSIVE WITH TYPE>',rtype - ! This error should not happen !(implies compiler bug as proc output type determined by args) - if(nret>0.and.rtype/=coder%stack(base)) then - call infer_error_with_trace(coder,prc,& + if(nret>0.and.rtype/=coder%stack(coder%base)) then + call inf_error_with_trace(coder,procnode,& 'Internal Compiler Error: Procedure return type changed') endif - + ! Flag procedure as recursive coder%taints=ior(coder%taints,proc_is_recursive) exit @@ -427,16 +409,13 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& enddo if(debug_inference) then - write(*,*) 'COMPLETED>',coder%stack(base),& - coder%stack(base-1),base,oldbase,coder%stack(oldbase-1) + write(*,*) 'COMPLETED>',coder%stack(coder%base),& + coder%stack(coder%base-1),coder%base endif ! Pass a break out if(coder%incomplete) then - if(debug_inference) then - write(*,*) 'OUTBREAK>',oldbase - endif - call pop_stack_frame(coder,base) + call pop_stack_frame(coder) ! clear cache entry cnode%offset=sp_sig_break call pm_dict_set_val(coder%context,& @@ -448,102 +427,39 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& endif coder%incomplete=save_incomplete - + ! Flag recursive calls with taints or keyword args as unfinished taints=iand(coder%taints,proc_taints) - if(iand(coder%taints,proc_is_recursive)/=0) then - if(taints>0.or.nkeys>0) then - coder%taints=ior(coder%taints,proc_unfinished) - endif - endif - + ! Create record of type-annotated code - call code_val(coder,prc) - call code_int_vec(coder,coder%stack,base,coder%top) + call code_val(coder,procnode) + call code_int_vec(coder,coder%stack,coder%base,coder%top) call code_num(coder,& - ior(iand(cnode_get_num(prc,pr_flags),& + ior(iand(cnode_get_num(procnode,pr_flags),& proc_is_comm+proc_run_shared+proc_run_local+proc_inline+& proc_no_inline+proc_run_complete+proc_run_always),& coder%taints)) - if(nkeys>0) then - call code_int_vec(coder,coder%wstack,& - coder%proc_key_base+1,coder%proc_key_base+nkeys) - else - call code_null(coder) - endif - call make_code(coder,pm_null_obj,cnode_is_resolved_proc,4) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) cnode=top_code(coder) - if(iscomm) then - key(3)=coder%par_kind - key(4)=coder%par_kind2 - else - key(3)=coder%par_kind - key(4)=-1 + if(debug_inference) then + write(*,*) coder%par_kind,'CACHE AS>',key(1:keysize),'>',cnode%offset endif - if(debug_inference) write(*,*) coder%par_kind,'CACHE AS>',key(1:keysize) k=pm_idict_add(coder%context,coder%proc_cache,& key,keysize,cnode) call drop_code(coder) - ! For tainted recursive calls - ! or recursive calls with keywords need one final pass - if(iand(coder%taints,proc_is_recursive)/=0) then - if(taints>0.or.nkeys>0) then - save_redo_calls=coder%redo_calls - coder%redo_calls=.true. - call init_stack_frame(coder,base,at,taints) - call prc_cblock(coder,cnode_arg(prc,1),base) - coder%redo_calls=save_redo_calls - call cnode_set_num(cnode,cnode_args+2,& - ieor(cnode_num_arg(cnode,3),proc_unfinished)) - endif - endif - - ! Now we have complete taints can check if proc needs par_kind - if(iand(coder%taints,proc_needs_par)==0) then - ! If not include a new entry - this will shadow entries - ! specialised on par_kind due to search order - key(3)=-1 - key(4)=-1 - if(debug_inference) write(*,*) 'RECACHE AS>',key(1:keysize) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,keysize,cnode) - endif - - ! Process special cases of 'each' procedures - if(iand(coder%taints,proc_is_not_pure_each)==0) then - if(.not.cnode_flags_clear(prc,pr_flags,& - proc_is_thru_each+proc_is_empty_each+proc_is_dup_each)) then - cnode=pm_fast_tinyint(coder%context,sp_sig_dup) - if(cnode_flags_set(prc,pr_flags,proc_is_thru_each)) then - cnode%offset=sp_sig_thru - elseif(cnode_flags_set(prc,pr_flags,proc_is_empty_each)) then - cnode%offset=sp_sig_noop - endif - k=pm_idict_add(coder%context,coder%proc_cache,& - key,keysize,cnode) - k=cnode%offset - endif - endif - call code_num(coder,int(k)) - call pop_stack_frame(coder,base) - call cnode_incr_num(prc,pr_recurse,-1) + call pop_stack_frame(coder) + call cnode_incr_num(procnode,pr_recurse,-1) - ! If calling (unresolved) proc is not the same as this proc - ! then this cannot be a pure each proc so taint it as such - if(.not.(prc==coder%proc)) then - coder%taints=ior(coder%taints,proc_is_not_pure_each) - endif - ! Pass out taint information coder%proc_taints=iand(coder%taints,proc_taints) coder%taints=ior(save_taints,coder%proc_taints) - + if(pm_debug_level>3) then - write(*,*) 'ENDPRC>',key(1),key(2),key(3),key(4),k + write(*,*) 'ENDPROCNODE>',key(1),key(2),key(3),key(4),k endif - + contains include 'fnewnc.inc' include 'fistiny.inc' @@ -551,224 +467,414 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& include 'fvkind.inc' include 'fesize.inc' include 'fisnull.inc' - end function prc_proc + end function inf_proc + + !======================================================================= + ! Process keyword arguments + ! This requires type inference of default expressions before checking + ! and converting the arguments + !======================================================================= + subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& + keytypes,n) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode,call_keys + integer,intent(in):: atype,nkeys,key_base + integer,intent(out):: keytypes(*),n + integer i,j,cname,pname,ctype,ptype,dtype,pdtype,mtype + logical:: nomatch,error + type(pm_ptr):: callkeys,proc_keys,arglist,tv + integer:: nargs,totargs,tno + + proc_keys=cnode_get(procnode,pr_keys) + + ! Need to infer standard arguments in case they are + ! used in default expressions + arglist=cnode_get(procnode,pr_argcall) + if(.not.pm_fast_isnull(arglist)) then + nargs=cnode_numargs(arglist) + tv=pm_type_vect(coder%context,atype) + totargs=pm_tv_numargs(tv) + do i=1,nargs + call set_var_type(coder,cnode_arg(arglist,i),pm_tv_arg(tv,i)) + enddo + if(totargs>nargs) then + call push_word(coder,pm_type_is_tuple) + call push_word(coder,0) + j=0 + do i=nargs,totargs + call push_word(coder,pm_tv_arg(tv,i)) + j=j+1 + enddo + call make_type(coder,j+2) + call set_var_type(coder,cnode_arg(arglist,nargs),pop_word(coder)) + endif + endif + + arglist=cnode_get(procnode,pr_keycall) + n=pm_fast_esize(proc_keys)/2 + keytypes(1:n)=undefined + callkeys=pm_name_val(coder%context,int(call_keys%offset)) + + ! Find matching keyword parameter for each call keyword argument + ! and set the type for that parameter + outer: do i=0,nkeys-1 + cname=callkeys%data%i(callkeys%offset+i) + ctype=coder%wstack(key_base+1+i) + do j=1,n + pname=proc_keys%data%i(proc_keys%offset+j-1) + if(cname==pname) then + keytypes(j)=ctype + cycle outer + endif + enddo + call inf_error(coder,callnode,'Keyword argument "'//& + trim(pm_name_as_string(coder%context,cname))//& + '" does not match a keyword in the procedure definition') + call inf_error(coder,procnode,& + 'Procedure definition corresponding to the above error') + enddo outer + + ! For each keyword parameter, infer the default type and then + ! determine keyword argument matching with any required conversions + ! - match_arg will leave conversion records on the vstack + do i=1,n + call inf_cblock(coder,cnode_arg(arglist,i*2-1+n+n)) + dtype = get_arg_type(coder,callnode,cnode_arg(arglist,i*2+n+n)) + if(pm_type_kind(coder%context,dtype)==pm_type_is_literal) then + dtype=pm_type_arg(coder%context,dtype,1) + endif + if(keytypes(i)>=0) then + ptype=proc_keys%data%i(proc_keys%offset+i-1+n) + pdtype=merge(ptype,dtype,ptype>=0) + mtype=match_arg(coder,callnode,procnode,& + pdtype,keytypes(i),-i,3,nomatch,error) + if(nomatch) then + if(ptype>=0) then + call inf_error(coder,callnode,'Keyword argument "'//& + trim(pm_name_as_string(coder%context,proc_keys%data%i(proc_keys%offset)))//& + '" does not conform to the parameter type constraint') + else + call inf_error(coder,callnode,'Keyword argument "'//& + trim(pm_name_as_string(coder%context,proc_keys%data%i(proc_keys%offset)))//& + '" does not have the same type as the default value in the procedure definition') + endif + call more_error(coder%context,'Expected: '//trim(pm_type_as_string(coder%context,pdtype))) + call more_error(coder%context,'Got: '//& + trim(pm_type_as_string(coder%context,keytypes(i)))) + call inf_error(coder,procnode,'Definition corresponding to the above error') + call inf_trace(coder) + elseif(error) then + exit + else + keytypes(i)=mtype + endif + else + keytypes(i)=dtype + endif + call set_var_type(coder,cnode_arg(arglist,i),keytypes(i)) + call set_var_type(coder,cnode_arg(arglist,i+n),keytypes(i)) + enddo + contains + include 'fesize.inc' + include 'fisnull.inc' + end subroutine inf_key_args + ! ================================================== ! Type infer builtin procedure ! =================================================== - function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) + function inf_builtin(coder,procnode,atype,ptype) result(rtype) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: prc + type(pm_ptr),intent(in):: procnode integer,intent(in):: atype,ptype - integer,intent(in):: oldbase - integer:: rtype,mode - type(pm_ptr):: p - integer:: base,i - integer:: t1,t2 - integer,dimension(2):: key + integer:: rtype,mode,atype1 + integer,dimension(1):: key integer:: k - integer:: sym - type(pm_ptr):: tv,tv2 - logical:: isstatic + type(pm_ptr):: tv type(pm_type_einfo):: einfo + logical:: isstatic - ! Check cached type value - p=cnode_get(prc,bi_rcode) - if(pm_fast_istiny(p)) then - ! Result is type of one of the arguments - tv=pm_type_vect(coder%context,atype) - tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) - rtype=(pm_tv_arg(tv,int(p%offset))) - elseif(pm_fast_isnull(p)) then - ! A an actual return type has been specified - rtype=cnode_get_num(prc,bi_rtype) - if(rtype<0) then - ! Cached concrete return type - rtype=-rtype - else - ! Convert type to concrete only representation and cache it - if(rtype/=0) then - rtype=pm_type_as_concrete(coder%context,rtype,coder%wstack,& - isstatic) - if(isstatic) call cnode_set_num(prc,bi_rtype,int(-rtype)) - endif - endif - if(cnode_get_num(prc,bi_opcode)<0) then - rtype=fold(coder,prc,atype,rtype) - call code_num(coder,sp_sig_setval) - goto 10 - endif + rtype=cnode_get_num(procnode,pr_rtype) + if(rtype<0) then + ! Cached concrete return type + rtype=-rtype else - ! Process code for return expression to get base return type - base=create_stack_frame(coder,atype,cnode_num_arg(prc,2),0) - call prc_cblock(coder,cnode_get(prc,bi_rcode),base) - rtype=coder%stack(base) - call pop_stack_frame(coder,base) - - ! Special processing of return type - ! Specified by special character in return spec - sym=cnode_get_num(prc,bi_rsym) - if(rtype/=error_type) then - - select case(sym) - case(sym_hash,sym_pct) - tv=pm_type_vect(coder%context,rtype) - tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) - if(sym==sym_hash) then - rtype=(pm_tv_arg(tv,2)) - else - rtype=(pm_tv_arg(tv,1)) - endif - case(sym_dim1:sym_dim7) - tv=pm_type_vect(coder%context,rtype) - tv=pm_type_vect(coder%context,pm_type_strip_mode(coder%context,& - pm_tv_arg(tv,1),mode)) - if(pm_tv_kind(tv)==pm_type_is_vect) then - tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) - endif - rtype=pm_tv_arg(tv,int(sym-sym_dim1+1)) - case(sym_d1:sym_d7) - tv=pm_type_vect(coder%context,rtype) - tv=pm_type_vect(coder%context,pm_type_strip_mode(coder%context,& - pm_tv_arg(tv,1),mode)) - if(pm_tv_kind(tv)==pm_type_is_vect) then - rtype=pm_tv_arg(tv,1) - tv=pm_type_vect(coder%context,rtype) - rtype=pm_type_strip_mode(coder%context,pm_tv_arg(tv,int(sym-sym_d1+1)),mode) - if(modepm_tv_numargs(tv)) then +!!$ call inf_error_with_trace(coder,procnode,& +!!$ 'Internal error: PM__element_at: out of bounds') +!!$ rtype=error_type +!!$ else +!!$ rtype=pm_tv_arg(tv,t2) +!!$ endif +!!$ end select +!!$ endif +!!$ endif +!!$ ! Create cache entry +!!$ key(1)=-cnode_get_num(procnode,bi_id)-1 +!!$ k=pm_idict_add(coder%context,& +!!$ coder%proc_cache,key,1,procnode) +!!$ call code_num(coder,k) +!!$ +!!$10 continue +!!$ +!!$ ! Pass out taint information +!!$ coder%proc_taints=iand(proc_taints,cnode_get_num(procnode,pr_flags)) +!!$ coder%taints=ior(coder%taints,coder%proc_taints) contains include 'fisnull.inc' include 'fistiny.inc' include 'fnew.inc' include 'fvkind.inc' - end function prc_builtin + end function inf_builtin !========================================== ! Type infer code block !========================================== - subroutine prc_cblock(coder,cblock,base) + subroutine inf_cblock(coder,cblock) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock - integer,intent(in):: base integer:: nvars,i,newbase type(pm_ptr):: p if(pm_fast_isnull(cblock)) return p=cnode_get(cblock,cblock_first_call) do while(.not.pm_fast_isnull(p)) - call prc_call(coder,cblock,p,base) + call inf_call(coder,cblock,p) p=cnode_get(p,call_link) enddo contains include 'fisnull.inc' - end subroutine prc_cblock + end subroutine inf_cblock !======================================================= - ! Type infer call - ! (calls include control structures as a special case) + ! Type infer general calls + ! (which include control structures as a special case) !======================================================== - subroutine prc_call(coder,cblock,callnode,base) + subroutine inf_call(coder,cblock,callnode) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,cblock - integer,intent(in):: base integer:: sig integer:: tno,tno2,tno3,tno4,name,off,flags,mode,mode2 type(pm_ptr):: args,t,t2,tv,list,list2,namep - integer:: i,j,n,nret,nargs,nextra,slot,slot2,tbase,wbase + integer:: i,j,n,nret,nargs,slot,slot2,tbase,wbase integer:: vbase_check,tbase_check,counter,nerrors integer:: save_par_kind integer,dimension(2):: key @@ -802,15 +908,15 @@ subroutine prc_call(coder,cblock,callnode,base) do call clear_cblock_mark(list) call clear_cblock_mark(list2) - call prc_cblock(coder,list,base) + call inf_cblock(coder,list) call check_logical(3) if(arg_type(3)==coder%false_fix) return - call prc_cblock(coder,list2,base) + call inf_cblock(coder,list2) if(.not.(cblock_marked(list).or.& cblock_marked(list2))) exit counter=counter+1 if(counter>max_recur) then - call infer_error_with_trace(coder,args,& + call inf_error_with_trace(coder,args,& '"while" appears to lead to infinite types') exit endif @@ -822,16 +928,17 @@ subroutine prc_call(coder,cblock,callnode,base) call set_call_sig(0) endif case(sym_until,sym_each) + if(nargs<4) call inf_error(coder,callnode,'Towels') call check_loop_writes(4) list=cnode_arg(args,2) counter=0 do call clear_cblock_mark(list) - call prc_cblock(coder,list,base) + call inf_cblock(coder,list) if(.not.cblock_marked(list)) exit counter=counter+1 if(counter>max_recur) then - call infer_error_with_trace(coder,args,& + call inf_error_with_trace(coder,args,& trim(sym_names(sig))//' appears to lead to infinite types') exit endif @@ -843,18 +950,18 @@ subroutine prc_call(coder,cblock,callnode,base) call set_call_sig(0) endif case(sym_if,sym_if_invar) - call prc_if(nargs) + call inf_if(count_updates(cnode_arg(args,4),2)) case(sym_do,sym_for,sym_also) - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) case(sym_sync) - call prc_cblock(coder,cnode_arg(args,2),base) + call inf_cblock(coder,cnode_arg(args,2)) case(sym_over) - call prc_cblock(coder,cnode_arg(args,1),base) - call prc_cblock(coder,cnode_arg(args,2),base) + call inf_cblock(coder,cnode_arg(args,1)) + call inf_cblock(coder,cnode_arg(args,2)) case(sym_import_val,sym_import_param) tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot import uninitialised value into a nested parallel context:',& cnode_get(cnode_arg(args,2),var_name)) coder%stack(get_slot(1))=error_type @@ -866,15 +973,11 @@ subroutine prc_call(coder,cblock,callnode,base) mode,.false.) if(tno>0.and.coder%par_kind==par_mode_conc.and.mode==sym_shared) then if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot import distributed value into mirrored "forall"') coder%stack(get_slot(1))=error_type endif endif -!!$ write(*,*) 'import to',trim(pm_name_as_string(coder%context,& -!!$ cnode_get_num(cnode_arg(args,1),var_name))),coder%stack(get_slot(1)),tno,& -!!$ cnode_get_num(cnode_arg(args,2),var_index),cnode_get_num(cnode_arg(args,1),var_index),& -!!$ coder%stack(86),get_slot(1) call flag_import_export(tno) endif case(sym_import_varg) @@ -887,7 +990,7 @@ subroutine prc_call(coder,cblock,callnode,base) do i=1,n tno=pm_type_strip_mode(coder%context,pm_tv_arg(t,i),mode) if(iand(pm_type_flags(coder%context,tno),pm_type_has_distributed)/=0) then - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot use a shared value as an argument'//& ' to a non-communicating operation') endif @@ -899,20 +1002,16 @@ subroutine prc_call(coder,cblock,callnode,base) coder%stack(get_slot(1))=tno call flag_import_export(tno) endif -!!$ case(sym_import_shared) -!!$ tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) -!!$ coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,sym_shared,.false.) -!!$ call flag_import_export(tno) case(sym_export) tno=arg_type_with_mode(1) mode=pm_type_get_mode(coder%context,tno) if(mode/=sym_coherent.and.mode/=sym_partial) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& 'Cannot modify "'//trim(sym_names(mode))//'" variable as a "shared" value '//& 'in a nested parallel statement: '//& trim(pm_name_as_string(coder%context,& cnode_get_name(cnode_arg(args,1),var_name)))) - call infer_error_with_trace(coder,cnode_arg(args,1),& + call inf_error_with_trace(coder,cnode_arg(args,1),& 'Definition of variable in above error') endif call flag_import_export(0) @@ -923,7 +1022,7 @@ subroutine prc_call(coder,cblock,callnode,base) if(nargs>0) then coder%stack(get_slot(1))=arg_type_with_mode(2) endif - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot change variable in different parallel context') case(sym_pm_send:sym_pm_serve) call check_long(5) @@ -932,7 +1031,7 @@ subroutine prc_call(coder,cblock,callnode,base) tno=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) t=pm_type_vect(coder%context,tno) if(pm_tv_kind(t)/=pm_type_is_dref) then - call infer_error(coder,callnode,'Internal compiler error: Not a d-ref.') + call inf_error(coder,callnode,'Internal compiler error: Not a d-ref.') endif coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) if(sig==sym_pm_send.or.sig==sym_pm_collect) then @@ -940,31 +1039,31 @@ subroutine prc_call(coder,cblock,callnode,base) else coder%stack(get_slot(3))=pm_type_strip_mode(coder%context,pm_tv_arg(t,1),mode) endif - call prc_cblock(coder,cnode_arg(args,8),base) + call inf_cblock(coder,cnode_arg(args,8)) case(sym_pm_bcast) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=arg_type(3) coder%stack(get_slot(2))=arg_type(4) call check_long(5) - call prc_cblock(coder,cnode_arg(args,6),base) + call inf_cblock(coder,cnode_arg(args,6)) case(sym_pm_recv_req) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(3)) - call prc_cblock(coder,cnode_arg(args,5),base) + call inf_cblock(coder,cnode_arg(args,5)) case(sym_pm_recv_assn) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) coder%stack(get_slot(3))=pm_type_strip_mode_and_vect(coder%context,arg_type(5)) - call prc_cblock(coder,cnode_arg(args,7),base) + call inf_cblock(coder,cnode_arg(args,7)) case(sym_pm_do,sym_pm_do_at) do i=merge(1,3,sig==sym_pm_do),nargs-1,2 coder%stack(get_slot(i))=pm_type_strip_mode_and_vect(coder%context,arg_type(i+1)) enddo - call prc_cblock(coder,cnode_arg(args,nargs),base) + call inf_cblock(coder,cnode_arg(args,nargs)) case(sym_pm_head_node) - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) case(sym_pm_dref:sym_pm_ref) call push_word(coder,pm_type_new_dref) slot=coder%wtop @@ -997,7 +1096,7 @@ subroutine prc_call(coder,cblock,callnode,base) coder%stack(get_slot(1))=pop_word(coder) case(sym_hash) if(arg_type(2)/=pm_null) then - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) endif case(sym_for_stmt) coder%taints=ior(coder%taints,proc_needs_par) @@ -1017,8 +1116,8 @@ subroutine prc_call(coder,cblock,callnode,base) coder%stack(slot)=pm_long slot=get_slot(2) coder%stack(slot)=pm_null - call prc_cblock(coder,cnode_arg(args,4),base) - call prc_cblock(coder,cnode_arg(args,3),base) + call inf_cblock(coder,cnode_arg(args,4)) + call inf_cblock(coder,cnode_arg(args,3)) call make_code(coder,pm_null_obj,cnode_is_any_sig,0) coder%par_kind=coder%par_kind2 coder%par_kind2=save_par_kind @@ -1027,22 +1126,22 @@ subroutine prc_call(coder,cblock,callnode,base) coder%par_kind2=coder%par_kind coder%par_kind=par_mode_multi_node nerrors=coder%num_errors - call prc_cblock(coder,cnode_arg(args,4),base) + call inf_cblock(coder,cnode_arg(args,4)) list=cnode_arg(args,8) list=cnode_arg(list,1) slot=list%data%i(list%offset) slot2=list%data%i(list%offset+1) - coder%stack(base+slot:base+slot2)=undefined - call prc_cblock(coder,cnode_arg(args,3),base) + coder%stack(coder%base+slot:coder%base+slot2)=undefined + call inf_cblock(coder,cnode_arg(args,3)) coder%par_kind2=save_par_kind if(coder%num_errors==nerrors) then - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - coder%stack(base+slot:base+slot2)=undefined + call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) + coder%stack(coder%base+slot:coder%base+slot2)=undefined coder%par_kind=par_mode_single_node - call prc_cblock(coder,cnode_arg(args,3),base) + call inf_cblock(coder,cnode_arg(args,3)) if(coder%num_errors==nerrors) then - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - call prc_cblock(coder,cnode_arg(args,5),base) + call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) + call inf_cblock(coder,cnode_arg(args,5)) coder%par_kind=coder%par_kind2 coder%par_kind2=save_par_kind if(coder%num_errors==nerrors) then @@ -1071,12 +1170,12 @@ subroutine prc_call(coder,cblock,callnode,base) call set_call_sig(int(k)) case(sym_pct) if(nargs==1) then - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) else tno=arg_type(3) slot=get_slot(1) coder%stack(slot)=tno - call prc_cblock(coder,cnode_arg(args,2),base) + call inf_cblock(coder,cnode_arg(args,2)) endif case(sym_struct,sym_rec) t=cnode_arg(args,2) @@ -1100,20 +1199,17 @@ subroutine prc_call(coder,cblock,callnode,base) call push_word(coder,arg_type_with_mode(i+3)) enddo mode=pm_type_combine_modes(coder%context,& - coder%wstack(coder%wtop-nargs+3:coder%wtop),.false.,& - cnode_flags_set(callnode,call_flags,proc_run_complete),& - cnode_flags_set(callnode,call_flags,call_is_cond),& - cnode_flags_set(callnode,call_flags,call_is_unlabelled)) + coder%wstack(coder%wtop-nargs+3:coder%wtop),.false.) if(mode<0) then if(mode>-1000) then namep=pm_name_val(coder%context,pm_tv_name(t2)) - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot use a shared value'//& ' in "new" to initialise: '//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset-mode)))) else - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot use a "prtl" value in "new" '//& 'in a "cplt" context to initialise: '//& trim(pm_name_as_string(coder%context,& @@ -1129,7 +1225,7 @@ subroutine prc_call(coder,cblock,callnode,base) if(tno2==0.or.iand(pm_type_flags(coder%context,tno2),& pm_type_has_storage)/=0) then namep=pm_name_val(coder%context,pm_tv_name(t2)) - call infer_error(coder,callnode,'Element "'//& + call inf_error(coder,callnode,'Element "'//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset+i)))//& ':'//trim(pm_type_as_string(coder%context,tno2))//'" of "'//& @@ -1137,24 +1233,6 @@ subroutine prc_call(coder,cblock,callnode,base) '" needs to be initialised') endif endif - -!!$ tno4=pm_type_convert(coder%context,tno3,tno2,sig==sym_struct) -!!$ if(tno4>0) then -!!$ if(iand(pm_type_flags(coder%context,tno4),pm_type_has_params)/=0) then -!!$ namep=pm_name_val(coder%context,pm_tv_name(t2)) -!!$ call infer_error(coder,callnode,'Element "'//& -!!$ trim(pm_name_as_string(coder%context,& -!!$ namep%data%i(namep%offset+i)))//& -!!$ ':'//trim(pm_type_as_string(coder%context,tno4))//'" of "'//& -!!$ trim(pm_name_as_string(coder%context,name))//& -!!$ '" cannot be initialised') -!!$ call more_error(coder%context,& -!!$ 'unless the "new" statement supplies explict parameters for the type: new T(...) { }"') -!!$ endif -!!$ tno2=tno4 -!!$ !write(*,*) 'Converted to:',trim(pm_type_as_string(coder%context,tno4)) -!!$ endif - coder%wstack(coder%wtop-nargs+2+i)=tno2 enddo call make_type_if_possible(coder,nargs) @@ -1162,12 +1240,12 @@ subroutine prc_call(coder,cblock,callnode,base) if(tno2>0) then if(.not.pm_type_includes(coder%context,tno,tno2,& pm_type_incl_val,einfo)) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& '"'//trim(sym_names(sig))//& '" initial expression has wrong type for: ',& pm_fast_name(coder%context,name)) call pm_type_error(coder%context,einfo) - call infer_trace(coder) + call inf_trace(coder) tno2=error_type endif endif @@ -1204,19 +1282,6 @@ subroutine prc_call(coder,cblock,callnode,base) call set_arg_to_error_type(1) endif endif - case(sym_method_call) - tno=arg_type(2) - namep=cnode_arg(cnode_arg(args,3),1) - name=namep%offset - slot=resolve_elem(tno,name,.false.,.false.,tno2) - if(slot/=0) then - call combine_types(cnode_arg(args,1),tno2) - endif - call set_call_sig(slot) - case(sym_default) - tno=cnode_num_arg(cnode_arg(args,2),1) - slot=get_slot(1) - coder%stack(slot)=tno case(sym_cast) ! Arg 3 is type to cast to (-ve if in a conditional context) tno=arg_type(3) @@ -1227,14 +1292,14 @@ subroutine prc_call(coder,cblock,callnode,base) if(pm_type_kind(coder%context,tno)==pm_type_is_type) then tno=pm_type_arg(coder%context,tno,1) else - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& '"as" second argument is not a type') call set_arg_to_error_type(1) return endif tno2=pm_type_strip_mode_and_cond(coder%context,& arg_type_with_mode(2),mode,cond) - k=prc_cast(coder,callnode,tno,tno2,.true.) + k=inf_cast(coder,callnode,tno,tno2,.true.) call set_call_sig(int(k)) call combine_types(cnode_arg(args,1),& pm_type_add_mode(coder%context,tno2,mode,cond)) @@ -1245,7 +1310,7 @@ subroutine prc_call(coder,cblock,callnode,base) arg_type_with_mode(1),mode),mode2,.false.) if(mode==sym_partial.or.& mode2>=sym_mirrored.and.mode=sym_mirrored) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& 'Assignments to "'//trim(sym_names(tno))//& '" variables are not allowed outside of a "sync" statement') elseif(tno>=sym_chan) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& 'Assignments to "'//trim(sym_names(tno))//& '" variables must be labelled in a conditional context') endif @@ -1295,40 +1360,39 @@ subroutine prc_call(coder,cblock,callnode,base) call combine_types(cnode_arg(args,1),& pm_new_type_type(coder%context,tno)) case(sym_any) - call prc_any(nargs) - case(sym_each_proc) ! this controls body for proc.. each() - call prc_each_proc + call inf_any(count_updates(cnode_arg(args,5),2)) case(sym_test) - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) case(sym_check) if(.not.pm_fast_isnull(cnode_arg(args,2))) then - call prc_cblock(coder,cnode_arg(args,2),base) + call inf_cblock(coder,cnode_arg(args,2)) endif - call prc_cblock(coder,cnode_arg(args,4),base) + call inf_cblock(coder,cnode_arg(args,4)) tno=arg_type(3) if(pm_type_strip_to_basic(coder%context,arg_type(1))/=pm_string_type& .and.arg_type(1)/=error_type) then - call infer_error_with_trace(coder,cnode_arg(args,1),& + call inf_error_with_trace(coder,cnode_arg(args,1),& 'Check message is not a string, got:'//& trim(pm_type_as_string(coder%context,arg_type(1)))) elseif(tno==coder%false_fix) then if(cnode_get_kind(cnode_arg(args,1))==cnode_is_const) then call pm_strval(cnode_arg(cnode_arg(args,1),1),str) - call infer_error_with_trace(coder,callnode,str(1:len_trim(str))) + call inf_error_with_trace(coder,callnode,str(1:len_trim(str))) else - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Check condition will always fail') endif elseif(tno/=coder%true_fix) then call check_logical(3) - coder%stack(base-2)=ior(coder%stack(base-2),proc_is_impure) + coder%stack(coder%base-2)=ior(coder%stack(coder%base-2),proc_is_impure) endif case(sym_dash) tno=arg_type(2) t=pm_type_vect(coder%context,tno) if(iand(pm_tv_flags(t),pm_type_has_storage)/=0) then - call infer_error_with_trace(coder,callnode,& - 'Value after '' cannot be determined at compile time') + call inf_error_with_trace(coder,callnode,& + 'Value after '' cannot be determined at compile time: '//& + trim(pm_type_as_string(coder%context,tno))) endif if(pm_tv_kind(t)==pm_type_is_literal) then tno=pm_new_fix_type(coder%context,pm_type_val(coder%context,tno),& @@ -1340,7 +1404,7 @@ subroutine prc_call(coder,cblock,callnode,base) pm_new_vect_type(coder%context,arg_type(2)),sym_shared,.false.) case(sym_open) if(nargs>0) then - t=pm_type_vect(coder%context,coder%stack(base)) + t=pm_type_vect(coder%context,coder%stack(coder%base)) n=pm_tv_numargs(t) do i=1,nargs slot=get_slot(i) @@ -1362,53 +1426,16 @@ subroutine prc_call(coder,cblock,callnode,base) coder%stack(slot)=pop_word(coder) endif endif - coder%stack(base)=undefined + coder%stack(coder%base)=undefined case(sym_key) - t=cnode_arg(args,2) - t=cnode_arg(t,1) - slot2=coder%wstack(coder%proc_key_base+t%data%i(t%offset)) - coder%stack(get_slot(1))=slot2 + ! This is inferred in trav_proc + continue case(sym_present) - t=cnode_arg(args,4) - t=cnode_arg(t,1) - slot2=coder%wstack(coder%proc_key_base+t%data%i(t%offset)) - slot=arg_type(5) - if(slot/=slot2) then - if(slot2==pm_tiny_int) then - coder%wstack(coder%proc_key_base+t%data%i(t%offset))=slot - elseif(nargs>3) then - t=cnode_arg(args,6) - t=cnode_arg(t,1) - if(.not.pm_type_includes(coder%context,t%data%i(t%offset),& - slot2,pm_type_incl_val,& - einfo)) then - call infer_error(coder,callnode,'Keyword argument type mismatch:',& - cnode_get(cnode_arg(args,1),var_name)) - call more_error(coder%context,'Mismatched argument: '//& - trim(pm_type_as_string(coder%context,slot2))) - call more_error(coder%context,'Parameter type constraint: '//& - trim(pm_type_as_string(coder%context,t%data%i(t%offset)))) - call infer_trace(coder) - endif - slot=slot2 - else - t=cnode_arg(args,1) - t=cnode_get(t,var_name) - call infer_error(coder,callnode,& - 'Keyword argument type mismatch:',t) - call more_error(coder%context,'Mismatched argument: '//& - trim(pm_type_as_string(coder%context,slot2))) - call more_error(coder%context,'Mismatched parameter: '//& - trim(pm_type_as_string(coder%context,slot))) - call infer_trace(coder) - endif - endif - coder%stack(get_slot(1))=slot - coder%stack(get_slot(2))=pm_logical + call combine_types(cnode_arg(args,1),int(pm_logical)) case(sym_result) call get_arg_types_and_modes call make_type_if_possible(coder,nargs+2) - coder%stack(base)=pop_word(coder) + coder%stack(coder%base)=pop_word(coder) case(sym_start_loop) coder%stack(get_slot(2))=pm_logical case(sym_underscore,sym_colon,sym_end_loop,sym_init_var) @@ -1417,13 +1444,13 @@ subroutine prc_call(coder,cblock,callnode,base) call combine_types(cnode_arg(args,1),arg_type(2)) case(first_pragma:last_pragma) if(sig==sym_infer_type.or.sig==sym_infer_type_and_stack) then - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) endif if(sig==sym_infer_stack) then call cnode_error(coder,callnode,'Type inference stack trace:',warn=.true.) endif if(sig==sym_infer_type_and_stack.or.sig==sym_infer_stack) then - call infer_trace(coder) + call inf_trace(coder) endif case(sym_pm_dump) if(coder%first_pass) then @@ -1445,7 +1472,7 @@ subroutine prc_call(coder,cblock,callnode,base) end select else ! A positive signature (so sig<0) is a conventional procedure call - call prc_proc_call(coder,cblock,callnode,-sig,args,nargs,nret,base) + call inf_proc_call(coder,cblock,callnode,-sig,args,nargs,nret) endif ! Check stacks are in proper state (no stack leaks) @@ -1453,12 +1480,12 @@ subroutine prc_call(coder,cblock,callnode,base) if(vbase_check/=coder%vtop) then if(sig>0) write(*,*) 'in',sym_names(sig) write(*,*) 'MISMATCH-vstack',coder%vtop,vbase_check - call pm_panic('prc_call') + call pm_panic('inf_call') endif if(tbase_check/=coder%wtop) then if(sig>0) write(*,*) 'in',sym_names(sig) write(*,*) 'MISMATCH-wstack',coder%wtop,tbase_check - call pm_panic('prc_call') + call pm_panic('inf_call') endif endif @@ -1471,70 +1498,110 @@ subroutine prc_call(coder,cblock,callnode,base) include 'ftiny.inc' include 'ftypeno.inc' - subroutine prc_if(nargs) - integer,intent(in):: nargs - integer,dimension(4:nargs):: save_args + subroutine inf_if(nupdates) + integer,intent(in):: nupdates + integer,dimension(nupdates):: save_var_types integer:: i,tno,typ + type(pm_ptr):: changelist,writelist,p,var call check_logical(1) tno=arg_type(1) + changelist=cnode_arg(args,4) + writelist=cnode_arg(changelist,2) if(tno/=coder%false_fix) then if(tno==coder%true_fix.or.pm_fast_isnull(cnode_arg(args,3))) then - call prc_cblock(coder,cnode_arg(args,2),base) + call inf_cblock(coder,cnode_arg(args,2)) else - do i=4,nargs - save_args(i)=arg_type_with_mode(i) + i=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + save_var_types(i)=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) + i=i+1 end do - call prc_cblock(coder,cnode_arg(args,2),base) - do i=4,nargs - typ=save_args(i) - save_args(i)=arg_type_with_mode(i) - call set_arg_to_type(i,typ) + call inf_cblock(coder,cnode_arg(args,2)) + i=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + typ=save_var_types(i) + save_var_types(i)=get_var_type(coder,callnode,var) + call set_var_type(coder,var,typ) + p=p%data%ptr(p%offset+1) + i=i+1 end do - call prc_cblock(coder,cnode_arg(args,3),base) - do i=4,nargs - call combine_arg_types(i,save_args(i),no_init=.true.) + call inf_cblock(coder,cnode_arg(args,3)) + i=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call combine_var_type(coder,callnode,var,save_var_types(i)) + p=p%data%ptr(p%offset+1) + i=i+1 end do endif else - call prc_cblock(coder,cnode_arg(args,3),base) + call inf_cblock(coder,cnode_arg(args,3)) endif - end subroutine prc_if + end subroutine inf_if - subroutine prc_any(nargs) - integer,intent(in):: nargs - integer,dimension(5:nargs+1):: init_args,final_args + subroutine inf_any(nupdates) + integer,intent(in):: nupdates + integer,dimension(nupdates):: init_var_types,final_var_types integer:: i,j,slot,slot2 - type(pm_ptr):: list,list2 + type(pm_ptr):: changelist,writelist,list,list2,var,p list2=cnode_arg(args,4) list2=cnode_arg(list2,1) + changelist=cnode_arg(args,5) + writelist=cnode_arg(changelist,2) slot=list2%data%i(list2%offset) slot2=list2%data%i(list2%offset+1) tno=pm_type_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) t=check_poly(coder,tno) if(tno/=error_type.and..not.pm_fast_isnull(t)) then n=pm_set_size(coder%context,t) - do j=5,nargs+1 - init_args(j)=arg_type_with_mode(j) + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + init_var_types(j)=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) + j=j+1 end do do i=1,n - do j=5,nargs+1 - call set_arg_to_type(j,init_args(j)) + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call set_var_type(coder,var,init_var_types(j)) + p=p%data%ptr(p%offset+1) + j=j+1 end do list=pm_set_key(coder%context,t,int(i,pm_ln)) tno=list%data%i(list%offset) - coder%stack(base+slot:base+slot2)=undefined + coder%stack(coder%base+slot:coder%base+slot2)=undefined coder%stack(get_slot(1))=& pm_type_add_mode(coder%context,tno,mode,cond) - call prc_cblock(coder,cnode_arg(args,2),base) - call code_int_vec(coder,coder%stack,base+slot,base+slot2) + call inf_cblock(coder,cnode_arg(args,2)) + call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) if(i>1) then - do j=5,nargs+1 - call combine_arg_types(j,final_args(j),no_init=.true.) + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call combine_var_type(coder,callnode,var,final_var_types(j)) + p=p%data%ptr(p%offset+1) + j=j+1 end do endif - do j=5,nargs+1 - final_args(j)=arg_type_with_mode(j) + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + final_var_types(j)=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) + j=j+1 end do enddo call make_code(coder,pm_null_obj,cnode_is_any_sig,n) @@ -1546,94 +1613,12 @@ subroutine prc_any(nargs) call set_call_sig(int(k)) endif else - coder%stack(base+slot:base+slot2)=undefined + coder%stack(coder%base+slot:coder%base+slot2)=undefined call set_arg_to_error_type(1) - call prc_cblock(coder,cnode_arg(args,2),base) - endif - end subroutine prc_any - - subroutine prc_each_proc - t=cnode_arg(args,nret+4) - t=cnode_arg(t,1) - slot=t%data%i(t%offset) - slot2=t%data%i(t%offset+1) - tno=arg_type(nret+5) - if(tno<=0) then - do i=1,nret - call set_arg_to_error_type(i) - enddo - return - endif - t=pm_type_vect(coder%context,tno) - tno2=pm_tv_kind(t) - flags=iand(pm_tv_flags(t),pm_type_has_embedded) - name=pm_tv_name(t) - n=nargs-4 - if(tno2==pm_type_is_struct.or.tno2==pm_type_is_rec) then - do i=nret+7,nargs-1,2 - tno=arg_type(i) - t2=pm_type_vect(coder%context,tno) - if(pm_tv_kind(t2)/=tno2) then - if(coder%num_errors==0) & - call infer_error_with_trace(coder,callnode,& - '"proc <>" arguments cannot mix "struct" and "rec"') - endif - if(pm_tv_name(t2)/=name) then - if(coder%num_errors==0) & - call infer_error_with_trace(coder,callnode,& - '"proc <>" arguments must have the same "struct" or "rec" name') - endif - enddo - n=pm_tv_numargs(t) - if(nret>0) then - call check_wstack(coder,nret*(n+2)) - tbase=coder%wtop - coder%wtop=coder%wtop+nret*(n+2) - do i=1,nret - coder%wstack(tbase+(i-1)*(n+2)+1)=ior(tno2,flags) - coder%wstack(tbase+(i-1)*(n+2)+2)=name - enddo - endif - do i=1,n - do j=nret+5,nargs-1,2 - tno=arg_type(j) - t2=pm_type_vect(coder%context,tno) - tno=pm_tv_arg(t2,i) - coder%stack(get_slot(j+1))=tno - enddo - call prc_cblock(coder,cnode_arg(args,nret+3),base) - do j=1,nret - coder%wstack(tbase+(j-1)*(n+2)+i+2)=arg_type(nargs+j) - enddo - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - enddo - call make_code(coder,pm_null_obj,cnode_is_any_sig,n) - list=pop_code(coder) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - slot=cnode_get_num(callnode,call_index) - coder%stack(base+slot)=k - tno3=pm_type_from_recorded_name(coder%context,name) - do i=nret,1,-1 - call make_type_if_possible(coder,n+2) - if(.not.pm_type_includes(coder%context,tno3,tno2,pm_type_incl_val,einfo)) then - call infer_error(coder,args,& - '"'//trim(sym_names(tno2))//& - '" initial expression has wrong type for: ',& - pm_fast_name(coder%context,name)) - call pm_type_error(coder%context,einfo) - call infer_trace(coder) - endif - coder%stack(get_slot(i))=pop_word(coder) - enddo - call prc_cblock(coder,cnode_arg(args,nret+1),base) - else - call prc_cblock(coder,cnode_arg(args,nret+2),base) - slot=cnode_get_num(callnode,call_index) - coder%stack(base+slot)=0 + call inf_cblock(coder,cnode_arg(args,2)) endif - end subroutine prc_each_proc + end subroutine inf_any + !=================================================================== ! Push argument types with modes for all arguments @@ -1658,22 +1643,23 @@ end subroutine get_arg_types_and_modes function arg_type_with_mode(m) result(tno) integer,intent(in):: m integer:: tno - integer:: slot - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - if(pm_debug_checks) then - if(tno==undefined) then - call qdump_code_tree(coder,pm_null_obj,6,& - cnode_arg(args,m),2) - call infer_error_with_trace(coder,args,& - 'Internal Compiler Error: Broken type resulution::') - !!call pm_panic('Broken type resolution chain') - endif - endif - endif +!!$ integer:: slot + tno=get_arg_type(coder,callnode,cnode_arg(args,m)) +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ if(pm_debug_checks) then +!!$ if(tno==undefined) then +!!$ call qdump_code_tree(coder,pm_null_obj,6,& +!!$ cnode_arg(args,m),2) +!!$ call inf_error_with_trace(coder,args,& +!!$ 'Internal Compiler Error: Broken type resulution::') +!!$ !!call pm_panic('Broken type resolution chain') +!!$ endif +!!$ endif +!!$ endif end function arg_type_with_mode !=================================================================== @@ -1686,58 +1672,58 @@ function arg_type(m) result(tno) tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) end function arg_type - !=================================================================== - ! Return the type and mode for arguement m (no error check) - !================================================================== - function arg_type_noerr(m) result(tno) - integer,intent(in):: m - integer:: tno - integer:: slot - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - endif - end function arg_type_noerr - - !=================================================================== - ! Return the slot for arguement m (or -ve of typeno for a constant) - !================================================================== - function get_slot_or_type(m) result(slotno) - integer,intent(in):: m - integer:: slotno - type(pm_ptr):: v - v=cnode_arg(args,m) - - if(cnode_get_kind(v)==cnode_is_const) then - slotno=-cnode_num_arg(v,2) - else - slotno=cnode_get_num(v,var_index)+base - endif - end function get_slot_or_type - - !=================================================================== - ! Return the slot and type for arguement m - ! - slot will be -ve for a constant - !================================================================== - subroutine get_slot_and_type(m,slot,tno) - integer,intent(in):: m - integer,intent(out):: slot - integer,intent(out):: tno - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - if(pm_debug_checks) then - if(tno==undefined) then - call infer_error_with_trace(coder,args,& - 'Internal Compiler Error: Broken type resulution::') - endif - endif - endif - end subroutine get_slot_and_type +!!$ !=================================================================== +!!$ ! Return the type and mode for arguement m (no error check) +!!$ !================================================================== +!!$ function arg_type_noerr(m) result(tno) +!!$ integer,intent(in):: m +!!$ integer:: tno +!!$ integer:: slot +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ endif +!!$ end function arg_type_noerr + +!!$ !=================================================================== +!!$ ! Return the slot for arguement m (or -ve of typeno for a constant) +!!$ !================================================================== +!!$ function get_slot_or_type(m) result(slotno) +!!$ integer,intent(in):: m +!!$ integer:: slotno +!!$ type(pm_ptr):: v +!!$ v=cnode_arg(args,m) +!!$ +!!$ if(cnode_get_kind(v)==cnode_is_const) then +!!$ slotno=-cnode_num_arg(v,2) +!!$ else +!!$ slotno=cnode_get_num(v,var_index)+coder%base +!!$ endif +!!$ end function get_slot_or_type + +!!$ !=================================================================== +!!$ ! Return the slot and type for arguement m +!!$ ! - slot will be -ve for a constant +!!$ !================================================================== +!!$ subroutine get_slot_and_type(m,slot,tno) +!!$ integer,intent(in):: m +!!$ integer,intent(out):: slot +!!$ integer,intent(out):: tno +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ if(pm_debug_checks) then +!!$ if(tno==undefined) then +!!$ call inf_error_with_trace(coder,args,& +!!$ 'Internal Compiler Error: Broken type resulution::') +!!$ endif +!!$ endif +!!$ endif +!!$ end subroutine get_slot_and_type !=================================================================== ! Return the slot for arguement m (which must be a var) @@ -1751,7 +1737,7 @@ function get_slot(m) result(slotno) if(cnode_get_kind(v)/=cnode_is_var) & call pm_panic('get_slot') endif - slotno=cnode_get_num(v,var_index)+base + slotno=cnode_get_num(v,var_index)+coder%base end function get_slot !================================================================== @@ -1768,7 +1754,7 @@ subroutine check_logical(m) if(tno/=error_type) then if(tno/=pm_logical.and.tno/=coder%true_literal.and.tno/=coder%false_literal.and.& tno/=coder%true_fix.and.tno/=coder%false_fix) then - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Expecting boolean expression, got: '//& trim(pm_type_as_string(coder%context,tno))) endif @@ -1788,7 +1774,7 @@ subroutine check_long(m) tno=arg_type(m) if(tno/=error_type) then if(tno/=pm_long) then - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Expecting long expression, got: '//& trim(pm_type_as_string(coder%context,tno))) endif @@ -1796,27 +1782,25 @@ subroutine check_long(m) end subroutine check_long !======================================================================= - ! Check that arguments arg1..nargs of a loop call are not uninitialised - ! (these are in-loop writes) + ! Check that variables updated in a loop call are not uninitialised + ! Arg #arg must contain the changelist !======================================================================= - subroutine check_loop_writes(arg1) - integer,intent(in):: arg1 - integer:: i - do i=arg1,nargs - if(pm_type_kind(coder%context,arg_type(i))==pm_type_is_uninitialised) then - call infer_error(coder,callnode,& - 'A variable cannot be uninitialised at the start of a loop that changes it:',& - cnode_get(cnode_arg(args,i),var_name)) - call infer_error(coder,cnode_arg(args,i),'Declaration corresponding to the above') - call set_arg_to_error_type(i) - endif + subroutine check_loop_writes(arg) + integer,intent(in):: arg + type(pm_ptr):: changelists,p,var + changelists=cnode_arg(args,arg) + p=cnode_arg(changelists,2) + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + tno=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) enddo end subroutine check_loop_writes subroutine clear_cblock_mark(list) type(pm_ptr),intent(in):: list integer:: slot - slot=base+cnode_get_num(list,cblock_index) + slot=coder%base+cnode_get_num(list,cblock_index) coder%stack(slot)=0 end subroutine clear_cblock_mark @@ -1824,7 +1808,7 @@ function cblock_marked(list) result(marked) type(pm_ptr),intent(in):: list logical:: marked integer:: slot - slot=base+cnode_get_num(list,cblock_index) + slot=coder%base+cnode_get_num(list,cblock_index) marked=coder%stack(slot)/=0 end function cblock_marked @@ -1846,7 +1830,7 @@ end subroutine flag_import_export !================================================================== subroutine set_call_sig(k) integer,intent(in):: k - coder%stack(base+cnode_get_num(callnode,call_index))=k + coder%stack(coder%base+cnode_get_num(callnode,call_index))=k end subroutine set_call_sig !================================================================== @@ -1858,10 +1842,9 @@ end subroutine set_call_sig recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) integer,intent(in):: tno,name logical,intent(in):: isref,isopt - integer,intent(out):: elem_type - integer:: sig - integer:: base,key(2) + integer:: base,sig + integer:: key(2) type(pm_ptr):: svec base=coder%wtop @@ -1883,10 +1866,10 @@ recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) elseif(sig==0) then if(.not.isopt) then if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& 'Cannot take element of an uninitialised value') else - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Error accessing element "'//& trim(pm_name_as_string(coder%context,name))//& '" of type "'//& @@ -1938,66 +1921,27 @@ subroutine combine_types(vararg,typ,no_init) type(pm_ptr),intent(in)::vararg integer,intent(in):: typ logical,intent(in),optional:: no_init - integer:: slot - integer:: typ0,n - type(pm_ptr):: tv,p,q,var - if(typ==undefined) call pm_panic('combine types') - var=vararg - if(pm_debug_level>3) then - write(*,*) 'COMBINE TYPES> ',& - trim(pm_name_as_string(coder%context,cnode_get_name(var,var_name))) - endif - slot=base+cnode_get_num(var,var_index) - typ0=coder%stack(slot) - coder%stack(slot)=typ - if(typ/=typ0.and.typ0>0) then - if(typ0==error_type) then - coder%stack(slot)=typ0 - elseif(typ/=error_type.and.& - (present(no_init).or.& - pm_type_kind(coder%context,typ0)/=pm_type_is_uninitialised).and.& - coder%num_errors==0) then - if(pm_type_kind(coder%context,typ0)==pm_type_is_uninitialised.or.& - pm_type_kind(coder%context,typ)==pm_type_is_uninitialised) then - call cnode_error(coder,callnode,& - 'Variable/constant is not intialised in all branches of a conditional statment:',& - cnode_get(var,var_name)) - else - call cnode_error(coder,var,'Value does not have consistent type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - 'First: '//trim(pm_type_as_string(coder%context,typ0))) - call more_error(coder%context,& - 'Then: '//trim(pm_type_as_string(coder%context,typ))) - if(present(no_init)) then - call cnode_error(coder,callnode,& - 'Above type is inconsistent between branches of this statement') - else - call cnode_error(coder,callnode,'Type inconsistency occurs here') - endif - endif - endif - endif - + call combine_var_type(coder,cblock,vararg,typ,no_init=no_init) end subroutine combine_types - - end subroutine prc_call + end subroutine inf_call !================================================================== ! Conventional procedure call !================================================================== - subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) + subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,cblock,args - integer,intent(in):: sig,num_args,nret,base - logical:: is_comm,is_complete,is_cond,is_unlabelled,run_shared,ignore_rules - integer:: name,mode,mode2,expected_mode,i,j,tno,tno2,slot,flags - integer:: nargs,nkey,nextra,ressig,pdepth + integer,intent(in):: sig,num_args,nret + logical:: is_comm,is_cond,is_unlabelled,ignore_rules + integer:: name,mode,mode2,i,j,tno,tno2,slot,flags + integer:: nargs,nkey,keybase,ressig,amps logical:: undef_arg - type(pm_ptr):: arg,amps,proclist,t,tv + type(pm_ptr):: arg,keys,keynames,amplocs,proclist,t,tv + nargs=num_args + if(debug_inference) then write(*,*) 'PROCESS PROC CALL>',& trim(sig_name_str(coder,int(sig))),'@',& @@ -2005,65 +1949,53 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) if(cnode_get_kind(args)/=cnode_is_arglist) call pm_panic('not arglist') call qdump_code_tree(coder,pm_null_obj,6,callnode,2) endif + + ! extract characteristics of call + amps=cnode_get_num(callnode,call_amp) flags=cnode_get_num(callnode,call_flags) is_comm=iand(flags,call_is_comm)/=0 - is_complete=iand(flags,proc_run_complete)/=0 - is_cond=iand(flags,call_is_cond+proc_run_complete+proc_run_shared)==call_is_cond + is_cond=iand(flags,call_is_cond)/=0 is_unlabelled=iand(flags,call_is_unlabelled)/=0 ignore_rules=cnode_flags_set(callnode,call_flags,call_ignore_rules) - run_shared=iand(flags,proc_run_shared)/=0 - proclist=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) - nkey=cnode_get_num(callnode,call_nkeys) - nextra=0 + if(sig/=0) then + proclist=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) + endif + + undef_arg=.false. + + keys=cnode_get(callnode,call_keys) + keynames=cnode_get(callnode,call_key_names) + keybase=coder%wtop + if(.not.pm_fast_isnull(keys)) then + nkey=cnode_numargs(keys) + do i=1,nkey + tno=get_arg_type(coder,callnode,cnode_arg(keys,i)) + call push_word(coder,tno) + undef_arg=undef_arg.or.tno<=0 + enddo + else + nkey=0 + endif + + + ! Push arguments types to stack call push_word(coder,pm_type_is_tuple) - call push_word(coder,0) + call push_word(coder,amps) call check_wstack(coder,nargs) - undef_arg=.false. + do i=1,nargs - tno=arg_type_with_mode(i+nret) + tno=get_arg_type(coder,callnode,cnode_arg(args,i+nret),& + init=iand(flags,call_is_uninitialised)/=0) coder%wstack(coder%wtop+i)=tno undef_arg=undef_arg.or.tno<=0 enddo - if(is_comm) then - pdepth=cnode_get_num(cnode_arg(args,1+nret),var_par_depth) - ! Modify modes of arguments if necessary - do i=3,nargs - arg=cnode_arg(args,i+nret) - ! Set arguments from outside this context to shared - if(cnode_get_kind(arg)==cnode_is_var) then - if(cnode_get_num(arg,var_par_depth)==pdepth) then - coder%wstack(coder%wtop+i)=& - pm_type_replace_mode(coder%context,& - coder%wstack(coder%wtop+i),& - sym_shared,.false.) - endif - endif - ! In an unlabelled conditional context, set coherent to partial - if(is_unlabelled.and.& - pm_type_get_mode(coder%context,coder%wstack(coder%wtop+i))==sym_coherent) then - coder%wstack(coder%wtop+i)=& - pm_type_replace_mode(coder%context,& - coder%wstack(coder%wtop+i),& - sym_partial,.false.) - endif - enddo - elseif(run_shared) then - do i=1,nargs - if(cnode_get_kind(cnode_arg(args,i+nret))==cnode_is_var) then - if(.not.cnode_flags_set(cnode_arg(args,i+nret),var_flags,var_is_imported)) then - coder%wstack(coder%wtop+i)=& - pm_type_replace_mode(coder%context,& - coder%wstack(coder%wtop+i),& - sym_shared,.false.) - endif - endif - enddo - endif + + ! Error return for error argument in if(undef_arg) then do i=1,nret call set_arg_to_error_type(i) enddo - coder%wtop=coder%wtop-2 + coder%wtop=coder%wtop-2-nkey if(debug_inference) then write(*,*) 'END PROC CALL (FAILED ERR ARG)>',& trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop @@ -2073,6 +2005,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! Standard calls if(.not.is_comm) then + if(debug_inference) then do i=1,nargs write(*,*) 'PRE-STRIPPED',& @@ -2086,44 +2019,21 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! Implement mode combination rule for standard procedures mode=pm_type_combine_modes(coder%context,& coder%wstack(coder%wtop+1:coder%wtop+nargs),& - ignore_rules.or.run_shared,is_complete,is_cond,is_unlabelled) + ignore_rules) if(mode<0) then - if(mode>-1000) then - call call_error('Cannot pass a shared value to a standard procedure') - call infer_error_with_trace(coder,cnode_arg(args,nret-mode),& - 'Cannot pass a shared value to a standard procedure') - elseif(mode>-2000) then - call infer_error_with_trace(coder,cnode_arg(args,nret-mode-1000),& - 'Cannot pass a "partial" value to a "complete" procedure'//& - trim(sig_name_str(coder,int(sig)))) - elseif(.not.ignore_rules) then - call infer_error_with_trace(coder,cnode_arg(args,nret-mode-2000),& - 'Cannot pass a "coherent" value to a "complete" procedure in an unlabelled call in a conditional context: '//& - trim(sig_name_str(coder,int(sig)))) - endif + call call_error('Cannot pass a shared value to a standard procedure') + call inf_error_with_trace(coder,cnode_arg(args,nret-mode),& + 'Cannot pass a shared value to a standard procedure') mode=sym_coherent endif - ! Argument mode rules for specialised run modes - if(.not.ignore_rules) then - if(is_complete.and.mode==sym_partial) then - call call_error(& - 'Cannot pass "partial" value to a procedure with "<>" attribute') - elseif(run_shared.and.mode>" attribute') - endif - endif - ! Rules for "&" arguments - !!! -- Need better error positioning - amps=cnode_get(callnode,call_amp) - if(.not.pm_fast_isnull(amps).and..not.ignore_rules) then - amps=pm_name_val(coder%context,int(amps%offset)) - do i=0,pm_fast_esize(amps) +!!! -- Need better error positioning + if(amps/=0.and..not.ignore_rules) then + amplocs=pm_name_val(coder%context,amps) + do i=0,pm_fast_esize(amplocs) tno2=pm_type_strip_mode(coder%context,& - coder%wstack(coder%wtop+amps%data%i(amps%offset+i)+nkey),mode2) + coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey),mode2) if(tno2>0) then tv=pm_type_vect(coder%context,tno2) if(pm_tv_kind(tv)==pm_type_is_dref) then @@ -2135,21 +2045,11 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) pm_tv_name(tv)/=pm_dref_is_ref) then call call_error(& 'Cannot pass a mixed-mode reference as an "&" argument - must use "&&"') - coder%wstack(coder%wtop+amps%data%i(amps%offset+i)+nkey)=pm_tv_arg(tv,1) + coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey)=pm_tv_arg(tv,1) endif endif endif - if(is_complete) then - if(mode2/=sym_coherent.and.mode2/=sym_chan) then - call call_error('Cannot have "'//trim(sym_names(mode2))//& - '" "&" parameter alongside "<>" call attribute') - endif - elseif(run_shared) then - if(mode2/=sym_shared) then - call call_error('Cannot have "'//trim(sym_names(mode2))//& - '" "&" parameter alongside "<>" call attribute') - endif - elseif(mode2/=sym_partial.and.mode2/=sym_coherent.and.(mode2/=sym_chan.or.is_unlabelled)) then + if(mode2/=sym_partial.and.mode2/=sym_coherent.and.(mode2/=sym_chan.or.is_unlabelled)) then if(mode2==sym_chan) then call call_error('Cannot change "chan" variable in an unlabelled conditional context') else @@ -2187,26 +2087,24 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) endif endif endif - + ! Now run the call itself do j=1,nret coder%stack(get_slot(j))=undefined enddo - if(cnode_flags_set(proclist,cnode_args+1,proc_is_var)) then - ressig=var_call(proclist,& - pm_dict_key(coder%context,coder%sig_cache,int(sig,pm_ln))) - else + if(sig==0) then + ressig=var_call(callnode) + else ressig=simple_proc_call(sig,proclist) - if(debug_inference) write(*,*) 'RESSIG>',ressig,coder%incomplete,& + endif + + if(debug_inference) then + write(*,*) 'RESSIG>',ressig,coder%incomplete,& 'for', trim(sig_name_str(coder,int(sig))) endif ! Standard procedure return modes if(.not.is_comm) then -!!$ ! If procedure just called is tainted 'variant' set return modes to private -!!$ if(iand(coder%proc_taints,proc_is_variant)/=0) then -!!$ mode=merge(sym_partial,sym_complete,is_cond) -!!$ endif ! Apply return mode to returned values if(mode/=sym_coherent) then @@ -2215,21 +2113,24 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) coder%stack(get_slot(j)),mode,is_cond) enddo endif + endif - ! Tidy up + if(debug_inference) then do j=1,nret write(*,*) 'RETURN',j,& trim(pm_type_as_string(coder%context,coder%stack(get_slot(j)))) enddo endif - coder%wtop=coder%wtop-nargs-2 - slot=base+cnode_get_num(callnode,call_index) + + ! Tidy up + coder%wtop=coder%wtop-nargs-nkey-2 + slot=coder%base+cnode_get_num(callnode,call_index) coder%stack(slot)=ressig if(debug_inference) then write(*,*) 'END PROC CALL>',& - trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop + trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop,ressig,slot,coder%base endif contains @@ -2238,359 +2139,64 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) include 'fisnull.inc' include 'ftiny.inc' - !=================================================================== - ! Return type, without mode, for argument m - !================================================================== - function arg_type(m) result(tno) - integer,intent(in):: m - integer:: tno - integer:: mode - tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) - end function arg_type - - !=================================================================== - ! Return type and mode for arguement m - !================================================================== - function arg_type_with_mode(m) result(tno) - integer,intent(in):: m - integer:: tno - integer:: slot - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - if(pm_debug_checks) then - if(tno==undefined) then - write(*,*) m,slot,pm_main_process - call qdump_code_tree(coder,pm_null_obj,6,& - cnode_arg(args,m),2) - call infer_error_with_trace(coder,args,'Broken::') - !call pm_panic('Broken type resolution chain') - endif - endif - endif - end function arg_type_with_mode - - !=================================================================== - ! Return the slot for arguement n (which must be a var) - !================================================================== - function get_slot(m) result(slotno) - integer,intent(in):: m - integer:: slotno - type(pm_ptr):: v - v=cnode_arg(args,m) - if(pm_debug_checks) then - if(cnode_get_kind(v)/=cnode_is_var) & - call pm_panic('get_slot') - endif - slotno=cnode_get_num(v,var_index)+base - end function get_slot - - !=================================================================== - ! Return the slot for arguement n (or -ve of typeno for a constant) - !================================================================== - function get_slot_or_type(m) result(slotno) - integer,intent(in):: m - integer:: slotno - type(pm_ptr):: v - v=cnode_arg(args,m) - - if(cnode_get_kind(v)==cnode_is_const) then - slotno=-cnode_num_arg(v,2) - else - slotno=cnode_get_num(v,var_index)+base - endif - end function get_slot_or_type - - !=================================================================== - ! Set argument m to the error type - !================================================================== - subroutine set_arg_to_error_type(m) - integer:: m - integer:: slot - type(pm_ptr):: ptr - slot=get_slot(m) - coder%stack(slot)=error_type - end subroutine set_arg_to_error_type - - !=================================================================== - ! Augment the type stored in a given variable vararg by adding typ - !================================================================== - subroutine combine_types(vararg,typ,no_init) - type(pm_ptr),intent(in)::vararg - integer,intent(in):: typ - logical,intent(in),optional:: no_init - integer:: slot - integer:: typ0,n - type(pm_ptr):: tv,p,q,var - if(typ==undefined) call pm_panic('combine types') - var=vararg - if(pm_debug_level>3) then - write(*,*) 'COMBINE TYPES> ',& - trim(pm_name_as_string(coder%context,cnode_get_name(var,var_name))) - endif - slot=base+cnode_get_num(var,var_index) - typ0=coder%stack(slot) - coder%stack(slot)=typ - if(typ/=typ0.and.typ0>0) then - if(typ0==error_type) then - coder%stack(slot)=typ0 - elseif(typ/=error_type.and.& - (present(no_init).or.& - pm_type_kind(coder%context,typ0)/=pm_type_is_uninitialised).and.& - coder%num_errors==0) then - if(pm_type_kind(coder%context,typ0)==pm_type_is_uninitialised.or.& - pm_type_kind(coder%context,typ)==pm_type_is_uninitialised) then - call cnode_error(coder,callnode,& - 'Variable is not intialised in all branches of a conditional statment:',& - cnode_get(var,var_name)) - else - call cnode_error(coder,var,'Variable changes type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - 'From: '//trim(pm_type_as_string(coder%context,typ0))) - call more_error(coder%context,& - 'To: '//trim(pm_type_as_string(coder%context,typ))) - if(present(no_init)) then - call cnode_error(coder,callnode,& - 'Type change occurs between branches of this statement') - else - call cnode_error(coder,callnode,'Type change occurs here') - endif - endif - endif - endif - - end subroutine combine_types - - !========================================= - ! Print error message for a call - !========================================= - subroutine call_error(str) - character(len=*):: str - call infer_error(coder,callnode,str) - call print_call_details(coder,callnode,coder%wtop,nargs) - call infer_trace(coder) - end subroutine call_error - - !================================================ - ! Call with variable procedure name: v.(args) - !================================================ - function var_call(prlist,callsig) result(k) - type(pm_ptr),intent(in):: prlist,callsig - integer:: k - integer:: i,sig,rsig - type(pm_ptr):: pr,var,tv,tv2 - integer:: tno,tno2,name - logical:: err - ! Get value for procedure name (actually its type) - var=cnode_get(callnode,call_var) - if(cnode_get_kind(var)==cnode_is_var) then - tno=coder%stack(cnode_get_num(var,var_index)+base) - else - tno=cnode_num_arg(var,2) - endif - if(tno==error_type) then - do i=1,nret - call set_arg_to_error_type(i) - enddo - return - endif - tv=pm_type_vect(coder%context,tno) - if(pm_tv_kind(tv)==pm_type_is_par_kind) then - tno=pm_tv_arg(tv,1) - tv=pm_type_vect(coder%context,tno) - endif - coder%wstack(coder%wtop-nargs)=tno - if(pm_tv_kind(tv)/=pm_type_is_proc) then - call infer_error_with_trace(coder,callnode,& - 'Value does not hold proc name; got: '//& - trim(pm_type_as_string(coder%context,tno))) - do i=1,nret - call set_arg_to_error_type(i) - enddo - k=undefined - return - endif - name=abs(pm_tv_name(tv)) - - ! Now look for a signature with this name and process it - rsig=undefined - do i=5,cnode_numargs(prlist),2 - if(name==cnode_num_arg(prlist,i)) then - sig=cnode_num_arg(prlist,i+1) - pr=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) - if(pm_tv_name(tv)>=0) then - rsig=simple_proc_call(sig,pr,issig=.true.) - else - tno2=pm_tv_arg(tv,1) - tv2=pm_type_vect(coder%context,tno2) - rsig=simple_proc_call(sig,pr,sigpars=pm_tv_arg(tv2,1),& - sigtyp=tno,issig=.true.) - if(rsig>0) call check_call_against_sig(tno,tv,callsig) - endif - k=rsig - return - endif - enddo - call infer_error_with_trace(coder,callnode,& - 'No match found for ".()" call using procedure name: '//& - trim(pm_name_as_string(coder%context,name))) - k=undefined - end function var_call - - !======================================================= - ! If a call is v.(args) with v of a signature type - ! then it is necessary to check the call against - ! the signature - !======================================================= - subroutine check_call_against_sig(tno,tvp,callsig) - integer,intent(in):: tno - type(pm_ptr),intent(in):: tvp,callsig - integer:: tno2,i,k,tno3 - type(pm_ptr):: tv,tv2,tv3,amplocs - type(pm_type_einfo):: einfo - integer:: nret,flags,n,mode,argmode - - tv=pm_type_vect(coder%context,pm_tv_arg(tvp,1)) - - ! Get information on call - i=callsig%offset+pm_fast_esize(callsig) - nret=callsig%data%i(i-1) - flags=callsig%data%i(i-3) - - ! Check type of call - name=pm_tv_name(tv) - if(iand(flags,call_is_comm)/=0) then - if(name/=sym_pct) then - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Expecting communicating "%" procedure') - goto 10 - endif - elseif(name/=sym_proc) then - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Not expecting communicating "%" procedure') - goto 10 - endif - - ! Check returns - tno2=pm_tv_arg(tv,2) - tv2=pm_type_vect(coder%context,tno2) - n=pm_tv_numargs(tv2) - if(nret/=n) then - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,'Different number of return values') - goto 10 - endif - do i=1,n - if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& - arg_type(i),pm_type_incl_val,einfo)) then - - !!!! Check conversion to interface/proc_sig - - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Return type mismatch: '//& - trim(pm_type_as_string(coder%context,pm_tv_arg(tv2,i)))//& - ' vs: '//& - trim(pm_type_as_string(coder%context,arg_type(i)))) - endif - enddo - - return -10 continue - - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call infer_trace(coder) - - end subroutine check_call_against_sig - !======================================================================== ! Procedure call for which signature has been resolved ! (either simple in the first place or an option for a vcall) ! - If err is present then no error messages - set err to true instead - ! - If sigpars/sigtyp present then introduce a signature type into the - ! procedure matching process - ! - If issig is present then disable visibility rule (for "." call) + ! - If sig_start is present then disable visibility rule (for "." call) !======================================================================== - function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(ressig) + function simple_proc_call(sig,procs,err,sig_start) result(ressig) integer,intent(in):: sig type(pm_ptr),intent(in):: procs logical,intent(out),optional:: err - integer,intent(in),optional:: sigpars,sigtyp - logical,intent(in),optional:: issig + integer,intent(in),optional:: sig_start integer:: ressig integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass integer:: vbase,wbase - type(pm_ptr):: v,proc,rtvect + type(pm_ptr):: v,proc,match_proc,rtvect integer:: rt,rt2,pars,mpars,apars,tno,match_pars logical:: ok,found,visible,found_has_no_rtypes - integer:: save_proc_key_base,save_par_kind,save_par_kind2 - type(pm_ptr):: keynames + integer:: save_par_kind,save_par_kind2 type(pm_type_einfo):: einfo integer,dimension(1):: key integer:: memo ! Save some state information - save_proc_key_base=coder%proc_key_base - coder%proc_key_base=coder%wtop-nargs save_par_kind=coder%par_kind save_par_kind2=coder%par_kind2 if(present(err)) err=.false. start=coder%vtop - keynames=cnode_arg(procs,1) - if(pm_fast_isnull(keynames)) then - nkey_sig=0 - else - nkey_sig=pm_set_size(coder%context,keynames) - endif - + if(present(sig_start)) start=sig_start + ! For shared calls, step back par kinds if(cnode_flags_set(callnode,call_flags,proc_run_shared)) then coder%par_kind=coder%par_kind2 endif + ! For procedure signature "." call then don't check visibility + visible=present(sig_start) + ! Find matching signature - ! This is done in multiple passes with broader matching allowed in pass 2 + ! This is done in multiple passes with increasingly broader matching + ! allowed in passes 1..3 + if(pm_debug_level>4) write(*,*) 'Checking',cnode_numargs(procs),' sigs' found=.false. apars=error_type - ! For procedure signature "." call then don't check visibility - visible=present(issig) + outer: do jpass=0,3 if(debug_inference) write(*,*) 'MATCH PASS> ',jpass - do i=3,cnode_numargs(procs),2 - pars=cnode_num_arg(procs,i) - - ! If this call is for a proc signature, then restrict matching to that signature - if(present(sigpars)) then - if(pm_type_includes(coder%context,& - pars,sigpars,pm_type_incl_type,einfo)) then - mpars=sigpars - elseif(pm_type_includes(coder%context,& - sigpars,pars,pm_type_incl_type,einfo)) then - mpars=pars - else - cycle - endif - else - mpars=pars - endif + do i=1,cnode_numargs(procs) + proc=cnode_arg(procs,i) + + if(cnode_get_num(proc,pr_nret)/=nret) cycle + if(cnode_get_num(proc,pr_amps)/=amps) cycle + if(cnode_flags_set(proc,pr_flags,proc_is_comm).neqv.is_comm) cycle + !!! Deal with cond/uncond here + + pars=cnode_get_num(proc,pr_ptype) if(debug_inference) then write(*,*) 'CHECKING SIG',(i-1)/2,& @@ -2601,12 +2207,13 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(ressig) wbase=coder%wtop vbase=coder%vtop - apars=check_call_sig(coder,callnode,cnode_arg(procs,i+1),& - mpars,nargs-nkey,nextra,cnode_get_num(callnode,call_flags),jpass) + apars=match_call_sig(coder,callnode,proc,& + pars,nargs,call_flags,jpass) + if(apars>=0) then ! Check for a visible match - if(is_visible(coder,callnode,cnode_arg(procs,i+1))) visible=.true. + if(is_visible(coder,callnode,proc)) visible=.true. ! If this is a second (or later) match, then check for compatibility if(found) then @@ -2618,27 +2225,27 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(ressig) ! in the case where the enclosing procedure defines return types ! and the first-match procedure does not define them if(nret>0.and.rt>0.and.found_has_no_rtypes) then - rt2=abs(cnode_get_num(cnode_arg(procs,i+1),pr_rtype)) + rt2=abs(cnode_get_num(proc,pr_rtype)) if(pm_type_kind(coder%context,rt2)/=pm_type_is_undef_result) then if(.not.pm_type_includes(coder%context,rt2,rt,pm_type_incl_type,einfo)) then - call infer_error(coder,proc,& + call inf_error(coder,proc,& 'Procedure returns type(s) not compatible'//& ' with an enclosing procedure to which it conforms') call pm_type_error(coder%context,einfo) - call infer_error(coder,cnode_arg(procs,i+1),& + call inf_error(coder,cnode_arg(procs,i+1),& 'Enclosing procedure referenced in above error') call more_error(coder%context,' ') - call print_call_details(coder,callnode,coder%proc_key_base,nargs) - call infer_trace(coder) + call print_call_details(coder,callnode,keybase,nargs) + call inf_trace(coder) endif endif endif cycle else if(.not.present(err)) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& 'Ambiguous call to: '//trim(sig_name_str(coder,int(sig)))) - call print_call_details(coder,callnode,coder%proc_key_base,nargs) + call print_call_details(coder,callnode,keybase,nargs) call print_proc_details(coder,cnode_arg(procs,i+1),& sig,& cnode_flags_set(callnode,call_flags,call_is_comm),& @@ -2659,24 +2266,27 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(ressig) ! infer the associated procedure found=.true. match_pars=pars - proc=cnode_arg(procs,i+1) + match_proc=proc found_has_no_rtypes=& - pm_type_kind(coder%context,cnode_get_num(proc,pr_rtype))==& + pm_type_kind(coder%context,cnode_get_num(match_proc,pr_rtype))==& pm_type_is_undef_result if(cnode_get_kind(proc)==cnode_is_builtin) then - rt=prc_builtin(coder,proc,apars,pars,base) + rt=inf_builtin(coder,proc,apars,pars) else pcheck=coder%vtop - ! Misuse loop stack as a traceback record + ! Traceback record ! of calls being processed coder%trace_depth=coder%trace_depth+1 if(coder%trace_depthpm_opts%proc_list.and..not.pm_opts%see_all_procs) then - call more_error(coder%context,& - '... (to see all procedures use -fsee-all-procs)') - exit - endif - enddo - endif - call infer_trace(coder) + + call more_error(coder%context,'Procedures considered:') + do m=1,cnode_numargs(procs) + pars=cnode_get_num(cnode_arg(procs,m),pr_ptype) + call print_proc_details(coder,cnode_arg(procs,m),& + sig,& + cnode_flags_set(callnode,call_flags,call_is_comm),& + pars) + if(m>pm_opts%proc_list.and..not.pm_opts%see_all_procs) then + call more_error(coder%context,& + '... (to see all procedures use -fsee-all-procs)') + exit + endif + enddo + call inf_trace(coder) do i=1,nret call set_arg_to_error_type(i) enddo @@ -2792,18 +2397,496 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(ressig) endif endif - ! Tidy up - coder%vtop=start - coder%proc_key_base=save_proc_key_base - coder%par_kind=save_par_kind - coder%par_kind2=save_par_kind2 - - end function simple_proc_call + ! Tidy up + coder%vtop=start + coder%par_kind=save_par_kind + coder%par_kind2=save_par_kind2 + + end function simple_proc_call + + !================================================ + ! Call with variable procedure name: v.(args) + !================================================ + function var_call(callnode) result(ressig) + type(pm_ptr),intent(in):: callnode + integer:: ressig + integer:: i,sig,rsig,apars + type(pm_ptr):: pr,var,tv,tv2 + integer:: proctyp,tno,name,start,arg(1) + logical:: err + + ! Get value for procedure name (actually its type) + var=cnode_get(callnode,call_var) + if(cnode_get_kind(var)==cnode_is_var) then + proctyp=coder%stack(cnode_get_num(var,var_index)+coder%base) + else + proctyp=cnode_num_arg(var,2) + endif + if(proctyp==error_type) then + goto 999 + endif + tv=pm_type_vect(coder%context,proctyp) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then + proctyp=pm_tv_arg(tv,1) + tv=pm_type_vect(coder%context,proctyp) + endif + coder%wstack(coder%wtop-nargs)=proctyp + + if(pm_tv_kind(tv)/=pm_type_is_proc) then + call inf_error_with_trace(coder,callnode,& + 'Value for ".()" call does not hold proc name, got: '//& + trim(pm_type_as_string(coder%context,proctyp))) + goto 999 + endif + name=abs(pm_tv_name(tv)) + arg(1)=name + sig=pm_ivect_lookup(coder%context,coder%sig_cache,arg,1) + if(sig>0) then + pr=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) + if(pm_tv_name(tv)>=0) then + start=coder%vtop + ressig=simple_proc_call(sig,pr,sig_start=start) + else + tno=pm_tv_arg(tv,1) + tv2=pm_type_vect(coder%context,tno) + call check_call_against_sig(proctyp,tv,callnode) + start=coder%vtop + apars=match_call_sig(coder,callnode,callnode,pm_tv_arg(tv2,1),nargs,& + cnode_get_num(callnode,call_flags),3,issig=.true.) + if(apars>0) then + ressig=simple_proc_call(sig,pr,sig_start=start) + if(ressig>0) call check_returns_against_sig(proctyp,tv,callnode) + ! Pop off extra set of arg types pushed by match_call_sig + coder%top=coder%wtop-nargs-2 + else + call inf_error(coder,callnode,& + 'Call arguments do not match procedure type'//& + ' and no conversions are available: '//& + pm_type_as_string(coder%context,proctyp)) + goto 999 + endif + endif + return + else + call inf_error_with_trace(coder,callnode,& + 'No match found for ".()" call using procedure name: '//& + trim(pm_name_as_string(coder%context,name))) + endif +999 continue + do i=1,nret + call set_arg_to_error_type(i) + enddo + ressig=undefined + end function var_call + + !======================================================= + ! If a call is v.(args) with v of a signature type + ! then it is necessary to check call characteristics + ! against the signature + !======================================================= + subroutine check_call_against_sig(tno,tvp,callnode) + integer,intent(in):: tno + type(pm_ptr),intent(in):: tvp,callnode + integer:: tno2,i,k,tno3 + type(pm_ptr):: tv,tv2,tv3,amplocs + type(pm_type_einfo):: einfo + integer:: nret,flags,n,mode,argmode + + tv=pm_type_vect(coder%context,pm_tv_arg(tvp,1)) + + ! Get information on call + nret=cnode_get_num(callnode,call_nret) + flags=cnode_get_num(callnode,call_flags) + + ! Check type of call + name=pm_tv_name(tv) + if(iand(flags,call_is_comm)/=0) then + if(name/=sym_pct) then + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,& + 'Expecting communicating "%" procedure') + endif + elseif(name/=sym_proc) then + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,& + 'Not expecting communicating "%" procedure') + endif + + end subroutine check_call_against_sig + + !======================================================= + ! If a call is v.(args) with v of a signature type + ! then it is necessary to check the returned values against + ! the signature + !======================================================= + subroutine check_returns_against_sig(tno,tvp,callsig) + integer,intent(in):: tno + type(pm_ptr),intent(in):: tvp,callsig + type(pm_ptr):: tv2 + integer:: tno2,tno3,i,k,n,at + type(pm_type_einfo):: einfo + + ! Check returns + tno2=pm_tv_arg(tv,2) + tv2=pm_type_vect(coder%context,tno2) + n=pm_tv_numargs(tv2) + if(nret/=n) then + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,'Different number of return values') + return + endif + do i=1,n + at=get_var_type(coder,callnode,cnode_arg(args,i)) + if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& + at,pm_type_incl_val,einfo)) then + + + !!!! Check conversion to interface/proc_sig + + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,& + 'Return type mismatch: '//& + trim(pm_type_as_string(coder%context,pm_tv_arg(tv2,i)))//& + ' vs: '//& + trim(pm_type_as_string(coder%context,at))) + endif + enddo + + return +10 continue + + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call inf_trace(coder) + + end subroutine check_returns_against_sig + +!!$ !=================================================================== +!!$ ! Return type, without mode, for argument m +!!$ !================================================================== +!!$ function arg_type(m) result(tno) +!!$ integer,intent(in):: m +!!$ integer:: tno +!!$ integer:: mode +!!$ tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) +!!$ end function arg_type +!!$ +!!$ !=================================================================== +!!$ ! Return type and mode for arguement m +!!$ !================================================================== +!!$ function arg_type_with_mode(m) result(tno) +!!$ integer,intent(in):: m +!!$ integer:: tno +!!$ integer:: slot +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ if(pm_debug_checks) then +!!$ if(tno==undefined) then +!!$ write(*,*) m,slot,pm_main_process +!!$ call qdump_code_tree(coder,pm_null_obj,6,& +!!$ cnode_arg(args,m),2) +!!$ call inf_error_with_trace(coder,args,'Broken::') +!!$ !call pm_panic('Broken type resolution chain') +!!$ endif +!!$ endif +!!$ endif +!!$ end function arg_type_with_mode +!!$ + !=================================================================== + ! Return the slot for arguement n (which must be a var) + !================================================================== + function get_slot(m) result(slotno) + integer,intent(in):: m + integer:: slotno + type(pm_ptr):: v + v=cnode_arg(args,m) + if(pm_debug_checks) then + if(cnode_get_kind(v)/=cnode_is_var) & + call pm_panic('get_slot') + endif + slotno=cnode_get_num(v,var_index)+coder%base + end function get_slot +!!$ +!!$ !=================================================================== +!!$ ! Return the slot for arguement n (or -ve of typeno for a constant) +!!$ !================================================================== +!!$ function get_slot_or_type(m) result(slotno) +!!$ integer,intent(in):: m +!!$ integer:: slotno +!!$ type(pm_ptr):: v +!!$ v=cnode_arg(args,m) +!!$ +!!$ if(cnode_get_kind(v)==cnode_is_const) then +!!$ slotno=-cnode_num_arg(v,2) +!!$ else +!!$ slotno=cnode_get_num(v,var_index)+coder%base +!!$ endif +!!$ end function get_slot_or_type + + !=================================================================== + ! Set argument m to the error type + !================================================================== + subroutine set_arg_to_error_type(m) + integer:: m + integer:: slot + type(pm_ptr):: ptr + slot=get_slot(m) + coder%stack(slot)=error_type + end subroutine set_arg_to_error_type + + !=================================================================== + ! Augment the type stored in a given variable vararg by adding typ + !================================================================== + subroutine combine_types(vararg,typ,no_init) + type(pm_ptr),intent(in)::vararg + integer,intent(in):: typ + logical,intent(in),optional:: no_init + call combine_var_type(coder,cblock,vararg,typ,no_init=no_init) + end subroutine combine_types + + !========================================= + ! Print error message for a call + !========================================= + subroutine call_error(str) + character(len=*):: str + call inf_error(coder,callnode,str) + call print_call_details(coder,callnode,coder%wtop,nargs) + call inf_trace(coder) + end subroutine call_error + + end subroutine inf_proc_call + + !==================================================== + ! Check if a procedure matches a given call signature + ! - defined by parameter tuple type pars + ! Call argument types must be nargs entries on wstack + ! Returns tuple of argument types (after any conversion) + ! Conversions are covered by ipass (see match_arg) + ! + !==================================================== + function match_call_sig(coder,callnode,procnode,pars,& + nargs,flags,ipass,issig) result(argtyp) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode + integer,intent(in):: pars + integer,intent(in):: nargs,flags,ipass + logical,intent(in),optional:: issig + integer:: argtyp + + logical:: nomatch,error + integer:: i,n,at,at2,pt,pk,wbase + type(pm_ptr):: pv + + if(pars==error_type) then + argtyp=undefined + return + endif + pv=pm_type_vect(coder%context,pars) + pk=pm_tv_kind(pv) + if(pm_debug_checks) then + if(pk/=pm_type_is_tuple.and.& + pk/=pm_type_is_vtuple) & + call pm_panic('check-sig') + endif - end subroutine prc_proc_call + if(debug_inference) then + write(*,*) 'Check call sig: (' + write(*,*) pars,' ',trim(pm_type_as_string(coder%context,pars)) + write(*,*) '----' + do i=1,nargs + at=coder%wstack(coder%wtop-nargs+i) + write(*,*) at,' ',trim(pm_type_as_string(coder%context,at)) + enddo + write(*,*) ')' + endif + + ! Allocate space for new argument types on wstack + wbase=coder%wtop + if(coder%wtop+nargs+2>max_code_stack) then + call pm_panic('Program too complex (match-sig)') + endif + coder%wtop=coder%wtop+nargs+2 + coder%wstack(wbase+1)=pm_type_is_tuple + coder%wstack(wbase+2)=0 + + ! Process each argument, converting if required + n=pm_tv_numargs(pv) + do i=1,nargs + at=coder%wstack(wbase-nargs+i) + if(at==undefined) call pm_panic('broken type resolution chain') + if(at==error_type) then + pt=0 + cycle + endif + if(i>n) then + if(pk/=pm_type_is_vtuple) then + argtyp=undefined + goto 10 + endif + else + pt=pm_tv_arg(pv,i) + endif + + at2=match_arg(coder,callnode,procnode,pt,at,i,ipass,nomatch,error) + if(error.or.nomatch) then + argtyp=undefined + goto 10 + endif + coder%wstack(wbase+i+2)=at2 + + enddo + + if(.not.present(issig)) then + + ! Bundle arguments into a single type + argtyp=pm_new_type(coder%context,coder%wstack(wbase+1:& + wbase+nargs+2)) + else + argtyp=1 + return + + endif + + ! Error exit point +10 continue + + ! Tidy up + coder%wtop=wbase + contains + include 'fisnull.inc' + include 'fnewnc.inc' + include 'fesize.inc' + end function match_call_sig + + !================================================================ + ! Match a single argument of type at to parameter type pt + ! applying automatic conversions as required + ! Returns converted argument type + ! nomatch - match failed + ! error - actual error raised (such as ambiguous match) + ! Any conversions will result in conversion record pushed on vstack + ! convesion record will refer to argument #ielem + ! Conversions applied are determined by ipass + ! 0 -- lexical to basic + ! 1 -- proc type conversion + ! 2 -- embedded types + ! 3 -- convert to poly type + !================================================================ + function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) result(new_at) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode + integer,intent(in):: pt,old_at,ielem,ipass + logical,intent(out):: nomatch,error + integer:: new_at + integer:: at,pt2,at2,base,status,flags + type(pm_type_einfo):: einfo + at=old_at + nomatch=.false. + error=.false. + flags=cnode_get_num(callnode,call_flags) + if(iand(flags,call_is_fixed)==0) then + at2=pm_type_convert(coder%context,pt,at,.true.,.false.,.false.) + if(at2>0) at=at2 + endif + if(pm_type_includes(coder%context,& + pt,at,pm_type_incl_val,einfo)) then + if(debug_inference) then + write(*,*) 'Match',trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) + endif + new_at=at + return + else + if(einfo%kind==pm_type_err_ambig) then + call cnode_error(coder,procnode,& + 'Ambiguous match to proc definition ( match in multiple alternatives)') + call cnode_error(coder,callnode,'... call being processed') + error=.true. + return + elseif(ipass>=1) then + pt2=pm_type_strip_to_basic(coder%context,pt) + at2=pm_type_convert(coder%context,pt,at,.false.,.true.,.false.) + if(at2/=undefined) then + new_at=at2 + return + endif + if(ipass==1) then + nomatch=.true. + return + elseif(ipass>=2) then + base=coder%wtop + ! Push index value for autoconv signature + call push_word(coder,ielem) + ! Check indirect inclusion + call pm_indirect_include(coder%context,pt,at,coder%wstack,max_code_stack,& + coder%wtop,einfo,at2,status) + if(status/=pm_elem_not_found) then + if(status==pm_elem_clash) then + call ambiguous_match_error(coder,callnode,pt,at,at2) + error=.true. + coder%wtop=base + return + endif + ! Match with indirect inclusion + ! Make autoconv object + call code_int_vec(coder,coder%wstack,base+1,coder%wtop) + coder%wtop=base + ! Correct parameter type to post-conversion value + new_at=at2 + return + else + if(ipass==3) then + ! On third pass check for poly conversions + at2=convert_poly(coder,pt2,at,.false.) + if(at2/=-1) then + call push_word(coder,at2) + call code_int_vec(coder,coder%wstack,base+1,coder%wtop) + ! Correct parameter type to post-conversion value + coder%wtop=base + new_at=at2 + return + endif + endif + ! No match found + if(debug_inference) then + write(*,*) 'Does not include',& + trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) + endif + nomatch=.true. + coder%wtop=base + return + endif + endif + else + ! No match found (pass 1) + if(debug_inference) then + write(*,*) 'Does not include',& + trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) + endif + nomatch=.true. + return + endif + endif + end function match_arg + + !================================================================= ! Is procnode directly visible from module containing callnode? !================================================================= @@ -2825,38 +2908,49 @@ function is_visible(coder,callnode,procnode) result(ok) ok=j>0 endif end function is_visible + + subroutine new_stack_frame(coder,max_index) + type(code_state),intent(inout):: coder + integer,intent(in):: max_index + coder%stack(coder%top+1)=coder%base + coder%base=coder%top+4 + coder%top=coder%base+max_index + if(coder%top>max_code_stack) & + call pm_panic('Program too complex (nested calls)') + end subroutine new_stack_frame + ! ================================================================================ ! Set up type inference frame ! Three control slots: - ! base-2 == taints for current procedure - ! base-1 == break value -- flags changing types, resolution not complete if /= 0 - ! base == argument (on entry) return (on exit) types + ! coder%base-2 == taints for current procedure + ! coder%base-1 == break value -- flags changing types, resolution not complete if /= 0 + ! coder%base == argument (on entry) return (on exit) types ! Remaining slots: - ! base+index == resolution information according to var or call index + ! coder%base+index == resolution information according to var or call index ! ================================================================================= - function create_stack_frame(coder,argtype,max_index,init_taints) result(base) + subroutine create_stack_frame(coder,argtype,max_index,init_taints) type(code_state),intent(inout):: coder integer,intent(in):: argtype,max_index,init_taints - integer:: base - base=coder%top+3 - coder%top=base+max_index + coder%stack(coder%top+1)=coder%base + coder%base=coder%top+4 + coder%top=coder%base+max_index if(coder%top>max_code_stack) & call pm_panic('Program too complex (nested calls)') - call init_stack_frame(coder,base,argtype,init_taints) - end function create_stack_frame + call init_stack_frame(coder,coder%base,1,coder%top,argtype,init_taints) + end subroutine create_stack_frame !=============================================================== ! (Re)initialise current stack frame !=============================================================== - subroutine init_stack_frame(coder,base,argtype,init_taints) + subroutine init_stack_frame(coder,base,first,last,argtype,init_taints) type(code_state),intent(inout):: coder - integer,intent(in):: base,argtype,init_taints + integer,intent(in):: base,first,last,argtype,init_taints integer:: i coder%stack(base-2)=init_taints coder%stack(base-1)=0 coder%stack(base)=argtype - do i=base+1,coder%top + do i=base+first,last coder%stack(i)=undefined enddo end subroutine init_stack_frame @@ -2864,10 +2958,11 @@ end subroutine init_stack_frame !=============================================================== ! Pop off current stack frame !=============================================================== - subroutine pop_stack_frame(coder,base) + subroutine pop_stack_frame(coder) type(code_state),intent(inout):: coder - integer,intent(in):: base - coder%top=base-3 + coder%top=coder%base-4 + coder%base=coder%stack(coder%base-3) + if(coder%base==0) call pm_panic('xxx') end subroutine pop_stack_frame !=============================================================== @@ -2881,6 +2976,7 @@ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) integer:: typ3 type(pm_ptr):: tv1,tv2 type(pm_type_einfo):: einfo + if(typ1<=0) return typ3=-1 tv1=pm_type_vect(coder%context,typ1) tv2=pm_type_vect(coder%context,typ2) @@ -2984,185 +3080,133 @@ function add_poly_to_poly(coder,poly_type,poly_type2) result(changed) include 'fisnull.inc' end function add_poly_to_poly - !==================================================== - ! Find procedure matching a given call signature - ! Call argument types must be on wstack - !==================================================== - function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,flags,ipass) result(tno) + !================================================= + ! Get currently resolved type (&mode) for argument + ! (variable or constant) + !================================================= + function get_arg_type(coder,callnode,arg,init) result(tno) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,matchnode - integer,intent(in):: pars - integer,intent(in):: nargs,ignore,flags,ipass + type(pm_ptr),intent(in):: callnode,arg + logical,intent(in),optional:: init integer:: tno - integer:: at,at2,pt,pt2,slot - type(pm_ptr):: pv,amb,av,vec,args - integer:: i,rel,n,base,wbase,pk,pk2,dbase,status - logical:: ok - type(pm_type_einfo):: einfo - if(pars==error_type) then - tno=undefined - return - endif - pv=pm_type_vect(coder%context,pars) - pk=pm_tv_kind(pv) - - if(pm_debug_checks) then - if(pk/=pm_type_is_tuple.and.& - pk/=pm_type_is_vtuple) & - call pm_panic('check-sig') - endif - - if(debug_inference) then - write(*,*) 'Check call sig: (' - write(*,*) pars,' ',trim(pm_type_as_string(coder%context,pars)) - write(*,*) '----' - do i=1,nargs - at=coder%wstack(coder%wtop-nargs+i) - write(*,*) at,' ',trim(pm_type_as_string(coder%context,at)) - enddo - write(*,*) ')' - endif - - wbase=coder%wtop - if(coder%wtop+nargs+2>max_code_stack) then - call pm_panic('Program too complex (check-sig)') - endif - - ! Start building return type on wstack - coder%wtop=coder%wtop+nargs+2 - coder%wstack(wbase+1)=pm_type_is_tuple - coder%wstack(wbase+2)=0 - n=pm_tv_numargs(pv) - if(n+ignore>nargs) then - tno=undefined - return - endif - do i=1,nargs - at=coder%wstack(wbase-nargs+i) - if(i<=ignore) then - coder%wstack(wbase+i+2)=at - cycle - endif - if(at==undefined) call pm_panic('broken type resolution chain') - if(at==error_type) then - pt=0 - cycle - endif - if(i>n+ignore) then - if(pk/=pm_type_is_vtuple) then - tno=undefined - goto 10 + if(cnode_get_kind(arg)==cnode_is_var) then + tno=get_var_type(coder,callnode,arg,init) + else + if(pm_debug_checks) then + if(cnode_get_kind(arg)/=cnode_is_const) then + call pm_panic('get_arg_type') endif - else - pt=pm_tv_arg(pv,i-ignore) endif - if(pm_type_kind(coder%context,at)==pm_type_is_uninitialised) then - if(iand(flags,call_is_uninitialised)/=0) then - at=pm_type_arg(coder%context,at,1) - else - call cnode_error(coder,callnode,& - 'Attempt to use "var" or "const" value before it is initialised') - args=cnode_get(callnode,call_args) - call cnode_error(coder,cnode_arg(args,i),& - 'Definition statement relating to above error') - tno=error_type - goto 10 + tno=cnode_num_arg(arg,2) + endif + end function get_arg_type + + !================================================= + ! Get currently resolved type (&mode) for variable + !================================================= + function get_var_type(coder,callnode,var,init) result(tno) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,var + logical,intent(in),optional:: init + integer:: tno + tno=coder%stack(cnode_get_num(var,var_index)+coder%base) +!!$ if(tno==undefined) then +!!$ call cnode_error(coder,callnode,& +!!$ 'Internal error: broken type resolution chain') +!!$ write(*,*) '###',cnode_get_num(var,var_index),cnode_get_num(var,var_index)+coder%base +!!$ tno=error_type +!!$ return +!!$ endif + if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then + if(present(init)) then + if(init) then + tno=pm_type_arg(coder%context,tno,1) + return endif endif - if(iand(flags,call_is_fixed)==0) then - at2=pm_type_convert(coder%context,pt,at,.true.,.false.,.false.) - if(at2>0) at=at2 - endif - if(pm_type_includes(coder%context,& - pt,at,pm_type_incl_val,einfo)) then - coder%wstack(wbase+i+2)=at - if(debug_inference) then - write(*,*) 'Match',trim(pm_type_as_string(coder%context,pt)),'<>',& - trim(pm_type_as_string(coder%context,at)) - endif - else - if(einfo%kind==pm_type_err_ambig) then - call cnode_error(coder,matchnode,& - 'Ambiguous match to proc definition ( match in multiple alternatives)') - call cnode_error(coder,callnode,'... call being processed') - elseif(ipass>=1) then - !pt2=pm_type_strip_to_basic(coder%context,pt) - at2=pm_type_convert(coder%context,pt,at,.false.,.true.,.false.) - if(at2/=undefined) then - coder%wstack(wbase+2+i)=at2 - goto 5 - endif - if(ipass==1) then - tno=undefined - goto 10 - elseif(ipass>=2) then - base=coder%wtop - ! Push index value for autoconv signature - call push_word(coder,nargs-i) - ! Check indirect inclusion - call pm_indirect_include(coder%context,pt,at,coder%wstack,max_code_stack,& - coder%wtop,einfo,at2,status) - if(status/=pm_elem_not_found) then - if(status==pm_elem_clash) then - call ambiguous_match_error(coder,callnode,pt,at,at2) - endif - ! Match with indirect inclusion - ! Make autoconv object - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - coder%wtop=base - ! Correct parameter type to post-conversion value - coder%wstack(wbase+i+2)=at2 + call cnode_error(coder,callnode,& + 'Attempt to use "var" or "const" value before it is initialised') + call cnode_error(coder,var,& + 'Definition statement relating to above error') + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + tno=error_type + return + endif + end function get_var_type + + !=============================================== + ! Set resolved type (& mode) for variable + !=============================================== + subroutine set_var_type(coder,var,tno) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: var + integer:: tno + coder%stack(cnode_get_num(var,var_index)+coder%base)=tno + end subroutine set_var_type + + !=============================================== + ! Return count of entries in an update list + !=============================================== + function count_updates(changelist,listno) result(n) + type(pm_ptr),intent(in):: changelist + integer,intent(in):: listno + integer:: n + type(pm_ptr):: p + p=cnode_arg(changelist,listno) + n=0 + do while(.not.pm_fast_isnull(p)) + n=n+1 + p=p%data%ptr(p%offset+1) + enddo + contains + include 'fisnull.inc' + end function count_updates + + !=============================================== + ! Combine a new type into the type recorded + ! for a given variable + !=============================================== + subroutine combine_var_type(coder,cnode,var,typ,no_init) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cnode,var + integer,intent(in):: typ + logical,intent(in),optional:: no_init + integer:: typ0,typ2 + typ0=get_var_type(coder,cnode,var) + typ2=typ0 + if(typ/=typ0) then + if(typ0<=0) then + typ2=typ + elseif(typ>0) then + if(present(no_init).or.& + pm_type_kind(coder%context,typ0)/=pm_type_is_uninitialised) then + if(pm_type_kind(coder%context,typ0)==pm_type_is_uninitialised.or.& + pm_type_kind(coder%context,typ)==pm_type_is_uninitialised) then + call cnode_error(coder,cnode,& + 'Variable/constant is not intialised in '//& + ' all branches of a conditional statment:',& + cnode_get(var,var_name)) + else + call cnode_error(coder,var,'Value does not have consistent type:',& + cnode_get(var,var_name)) + call more_error(coder%context,& + 'First: '//trim(pm_type_as_string(coder%context,typ0))) + call more_error(coder%context,& + 'Then: '//trim(pm_type_as_string(coder%context,typ))) + if(present(no_init)) then + call cnode_error(coder,cnode,& + 'Above type is inconsistent between branches of this statement') else - if(ipass==3) then - ! On third pass check for poly conversions - at2=convert_poly(coder,pt2,at,.false.) - if(at2/=-1) then - call push_word(coder,at2) - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - ! Correct parameter type to post-conversion value - coder%wstack(wbase+i+2)=at2 - goto 5 - endif - endif - - ! No match found - if(debug_inference) then - write(*,*) 'Does not include',& - trim(pm_type_as_string(coder%context,pt)),'<>',& - trim(pm_type_as_string(coder%context,at)) - endif - tno=undefined - goto 10 + call cnode_error(coder,cnode,'Type inconsistency occurs here') endif endif - else - ! No match found (pass 1) - if(debug_inference) then - write(*,*) 'Does not include',& - trim(pm_type_as_string(coder%context,pt)),'<>',& - trim(pm_type_as_string(coder%context,at)) - endif - tno=undefined - goto 10 endif + typ2=error_type endif -5 continue - enddo - - ! Bundle arguments into a single type - tno=pm_new_type(coder%context,coder%wstack(wbase+1:& - wbase+nargs+2)) - - ! Error exit point -10 continue - - ! Tidy up - coder%wtop=wbase - contains - include 'fisnull.inc' - include 'fnewnc.inc' - include 'fesize.inc' - end function check_call_sig + endif + call set_var_type(coder,var,typ2) + end subroutine combine_var_type + ! =============================================================== ! Error message for ambiguous match @@ -3172,15 +3216,15 @@ subroutine ambiguous_match_error(coder,callnode,pt,at,at2) type(code_state):: coder type(pm_ptr):: callnode integer,intent(in):: pt,at,at2 - call infer_error(coder,callnode,'Ambiguous match to embedded value:') + call inf_error(coder,callnode,'Ambiguous match to embedded value:') call pm_type_ambiguous_match_error(coder%context,pt,at,at2,coder%wstack,coder%wtop) - call infer_trace(coder) + call inf_trace(coder) end subroutine ambiguous_match_error !=========================================================== ! Type constraint / Cast !=========================================================== - function prc_cast(coder,node,tno1,tno2,isvar) result(k) + function inf_cast(coder,node,tno1,tno2,isvar) result(k) type(code_state):: coder type(pm_ptr),intent(in):: node integer,intent(in):: tno1 @@ -3237,14 +3281,14 @@ function prc_cast(coder,node,tno1,tno2,isvar) result(k) endif endif if(.not.ok) then - call infer_error(coder,node,& + call inf_error(coder,node,& 'Value cannot be cast to the given type') call pm_type_error(coder%context,einfo) - call infer_trace(coder) + call inf_trace(coder) endif contains include 'fisnull.inc' - end function prc_cast + end function inf_cast !============================================= ! Compile time computation of expressions @@ -3252,22 +3296,53 @@ end function prc_cast ! rstypes - typle of declared result types ! rtype - actual result type !============================================= - function fold(coder,prc,atype,rstype) result(rtype) + function fold(coder,procnode,atype,rstype) result(rtype) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: prc + type(pm_ptr),intent(in):: procnode integer,intent(in):: atype,rstype integer:: rtype - integer:: i,n,opcode,errno + integer:: i,n,opcode,errno,tno,tk,num_elem type(pm_ptr):: tv,arg1,arg2 type(pm_ptr):: result logical:: ok character(len=100):: emess type(pm_ptr):: rtv integer:: rtyp + type(pm_type_einfo):: einfo + tv=pm_type_vect(coder%context,atype) n=pm_tv_numargs(tv) - opcode=cnode_get_num(prc,bi_opcode) + opcode=cnode_get_num(procnode,bi_opcode) + if(opcode==op_num_elems_fold) then + coder%temp=pm_fast_newnc(coder%context,pm_long,1) + tno=pm_tv_arg(tv,1) + tk=pm_type_kind(coder%context,tno) + if(tk/=pm_type_is_struct.and.tk/=pm_type_is_rec) then + call inf_error_with_trace(coder,procnode,& + 'Can only apply "elements" to a "struct" or "rec", not: '//& + pm_type_as_string(coder%context,tno)) + num_elem=1 + else + num_elem=pm_type_numargs(coder%context,tno) + endif + coder%temp%data%ln(coder%temp%offset)=num_elem + rtype=pm_new_fix_type(coder%context,coder%temp) + return + elseif(opcode==op_type_include_fold) then + ok=pm_type_includes(coder%context,& + pm_type_arg(coder%context,& + pm_type_arg(coder%context,atype,1),1),& + pm_type_arg(coder%context,& + pm_type_arg(coder%context,atype,2),1),& + pm_type_incl_type,einfo) + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + return + endif arg1=pm_dict_val(coder%context,coder%context%tcache,& int(pm_tv_arg(tv,1),pm_ln)) if(n>1) then @@ -3275,14 +3350,16 @@ function fold(coder,prc,atype,rstype) result(rtype) int(pm_tv_arg(tv,2),pm_ln)) endif rtyp=pm_type_strip_to_basic(coder%context,pm_type_arg(coder%context,rstype,1)) + + !write(*,*) rtyp,'rtyp=',trim(pm_type_as_string(coder%context,rtyp)) + rtv=pm_type_vect(coder%context,rtyp) rtyp=pm_type_strip_to_basic(coder%context,pm_tv_arg(rtv,1)) - !write(*,*) rtyp,'rtyp=',trim(pm_type_as_string(coder%context,rtyp)) if(rtyp==pm_long) then coder%temp=pm_fast_newnc(coder%context,pm_long,1) call fold_value(opcode,coder%temp,arg1,arg2,ok,emess) if(.not.ok) then - call infer_error_with_trace(coder,prc,& + call inf_error_with_trace(coder,procnode,& 'Cannot combine run time values: '//trim(emess)) elseif(pm_tv_kind(rtv)==pm_type_is_unfixed) then rtype=pm_new_literal_type(coder%context,coder%temp) @@ -3291,7 +3368,6 @@ function fold(coder,prc,atype,rstype) result(rtype) endif elseif(rtyp==pm_string_type) then call fold_string(coder,opcode,arg1,arg2,coder%temp) - write(*,*) 'fold str' if(pm_tv_kind(rtv)==pm_type_is_unfixed) then rtype=pm_new_literal_type(coder%context,coder%temp) else @@ -3471,24 +3547,24 @@ end subroutine dump_res_sigs !=============================================== ! Output error message followed by call trace !=============================================== - subroutine infer_error_with_trace(coder,node,message,name) + subroutine inf_error_with_trace(coder,node,message,name) type(code_state):: coder type(pm_ptr),intent(in):: node character(len=*):: message type(pm_ptr),intent(in),optional:: name logical:: save_supress,current_supress current_supress=coder%supress_errors - call infer_error(coder,node,message,name) + call inf_error(coder,node,message,name) save_supress=coder%supress_errors coder%supress_errors=current_supress - call infer_trace(coder) + call inf_trace(coder) coder%supress_errors=save_supress - end subroutine infer_error_with_trace + end subroutine inf_error_with_trace !===================================== ! Output error message !===================================== - subroutine infer_error(coder,node,message,name) + subroutine inf_error(coder,node,message,name) type(code_state):: coder type(pm_ptr),intent(in):: node character(len=*):: message @@ -3526,9 +3602,9 @@ subroutine infer_error(coder,node,message,name) charno) if(present(name)) then call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//trim(message)//' '//trim(str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) else - str=trim(pm_opts%error)//message + str=trim(pm_opts%error)//' '//message endif write(*,'(A)') trim(str) endif @@ -3540,7 +3616,7 @@ subroutine infer_error(coder,node,message,name) if(coder%num_errors>max_code_errors) then call pm_stop('Too many type inference errors - compilation terminated') endif - end subroutine infer_error + end subroutine inf_error ! ============================================================ ! Output trace of current call stack @@ -3549,7 +3625,7 @@ end subroutine infer_error ! Ignores internal calls within PM__system ! unless pm_opts%hide_sysmod is false ! ============================================================= - subroutine infer_trace(coder) + subroutine inf_trace(coder) type(code_state):: coder type(pm_ptr):: node,modname,tv integer:: k,top @@ -3598,6 +3674,7 @@ subroutine infer_trace(coder) write(*,*) '--------------------------------------------------' write(*,*) contains + function hide(node) result(hideit) type(pm_ptr),intent(in):: node logical:: hideit @@ -3618,7 +3695,8 @@ function hide(node) result(hideit) endif !write(*,*) 'hide',hideit,name,sym_make_subref,sym_dump,pm_name_as_string(coder%context,name) end function hide - end subroutine infer_trace + + end subroutine inf_trace ! ============================================ ! Print details of individual call @@ -3634,10 +3712,9 @@ subroutine print_call_details(coder,node,base,numargs) character(len=2):: join,ampstr integer:: n,k,nargs,nkeys integer::ampidx,signame,signamebase - type(pm_ptr):: tv,key,val,amp,keyargs,name + type(pm_ptr):: tv,key,val,amp,keyargs,keynames,name if(.not.pm_main_process) return if(coder%supress_errors) return - nkeys=cnode_get_num(node,call_nkeys) nargs=cnode_numargs(cnode_get(node,call_args))-cnode_get_num(node,call_nret) if(present(numargs)) nargs=numargs k=0 @@ -3645,8 +3722,14 @@ subroutine print_call_details(coder,node,base,numargs) coder%sig_cache,int(cnode_get_num(node,call_sig),pm_ln)) val=pm_dict_val(coder%context,& coder%sig_cache,int(cnode_get_num(node,call_sig),pm_ln)) - keyargs=cnode_arg(val,1) - ampidx=key%data%i(key%offset+pm_fast_esize(key)-2) + keyargs=cnode_get(node,call_keys) + if(pm_fast_isnull(keyargs)) then + nkeys=0 + else + nkeys=cnode_numargs(cnode_get(node,call_keys)) + endif + + ampidx=cnode_get_num(node,call_amp) if(ampidx==0) then amp=pm_null_obj else @@ -3686,51 +3769,46 @@ subroutine print_call_details(coder,node,base,numargs) signame))//'%(') call more_error(coder%context,' region: '//& trim(pm_type_as_string(coder%context,& - coder%wstack(base+nkeys+1),distr=.true.))) + coder%wstack(base+1),distr=.true.))) call more_error(coder%context,' schedule: '//& trim(pm_type_as_string(coder%context,& - coder%wstack(base+nkeys+2),distr=.true.))) + coder%wstack(base+2),distr=.true.))) call more_error(coder%context,' here: '//& trim(pm_type_as_string(coder%context,& - coder%wstack(base+nkeys+3),distr=.true.))) + coder%wstack(base+3),distr=.true.))) n=3 endif - do i=nkeys+n+1,nargs + do i=n+1,nargs if(i0) then join=', ' else join=' ' endif - call check_amp(i-nkeys) + call check_amp(i) call more_error(coder%context,& ' '//ampstr//& - trim(pm_type_as_string(coder%context,coder%wstack(base+i)))//join) + trim(pm_type_as_string(coder%context,coder%wstack(base+nkeys+2+i)))//join) enddo if(.not.present(numargs).and.cnode_flags_set(node,call_flags,call_is_vararg)) then call more_error(coder%context,' ...') endif + keynames=pm_name_val(coder%context,cnode_get_num(node,call_key_names)) do i=1,nkeys if(i1) write(*,*) 'TYPE INFERENCE>>' - call prc_prog(coder) + call inf_prog(coder) if(pm_opts%out_typelist) then write(*,*) 'TOTAL TYPES::',pm_dict_size(context,context%tcache) endif - if(pm_opts%out_typelist) then + if(pm_opts%out_typelist.and..false.) then open(unit=4,file='types.out') save_members=pm_opts%show_members save_elems=pm_opts%show_elems diff --git a/src/opts.f90 b/src/opts.f90 index 69e1beb..14607dd 100755 --- a/src/opts.f90 +++ b/src/opts.f90 @@ -66,6 +66,7 @@ module pm_options logical:: ftn_name_elems character(len=25):: error + character(len=7):: error_start logical:: colour end type pm_opts_type @@ -76,7 +77,7 @@ module pm_options subroutine init_opts(context) type(pm_context),pointer:: context - logical:: colour + logical:: colour,bright pm_opts%inline=.true. pm_opts%check_stmts=.not.pm_is_compiling pm_opts%show_elems=.false. @@ -110,8 +111,14 @@ subroutine init_opts(context) pm_opts%ftn_name_types=.false. pm_opts%ftn_name_elems=.false. colour=pm_colour_messages.and.pm_isatty(6) + bright=pm_bright_messages + if(bright) then + pm_opts%error_start=pm_error_start_bright + else + pm_opts%error_start=pm_error_start + endif if(colour) then - pm_opts%error=pm_error_start//'Error: '//pm_error_end + pm_opts%error=pm_opts%error_start//'Error:'//pm_error_end else pm_opts%error='Error: ' endif @@ -161,6 +168,8 @@ subroutine help write(*,*) ' GENERAL OPTIONS' write(*,*) ' -N Do not colour-highlight error messages' write(*,*) ' -H Colour-highlight error messages' + write(*,*) ' -HB Colour-highlight error messages using bright colours' + write(*,*) ' -HS Colour-highlight error messages using standard colours' if(pm_is_compiling) then write(*,*) write(*,*) ' OPTIMISER OPTIONS' @@ -226,11 +235,19 @@ subroutine pm_get_command_line(context,mname) write(*,*) 'Not a command line option: ',trim(arg) call usage() endif - elseif(arg(1:2)=='-N') then - pm_opts%error='Error: ' + elseif(arg=='-N') then + pm_opts%error='Error:' pm_opts%colour=.false. - elseif(arg(1:2)=='-H') then + elseif(arg=='-HS') then pm_opts%error=pm_error_start//'Error: '//pm_error_end + pm_opts%error_start=pm_error_start + pm_opts%colour=.true. + elseif(arg=='-HB') then + pm_opts%error=pm_error_start_bright//'Error: '//pm_error_end + pm_opts%error_start=pm_error_start_bright + pm_opts%colour=.true. + elseif(arg=='-H') then + pm_opts%error=pm_opts%error_start//'Error: '//pm_error_end pm_opts%colour=.true. elseif(arg(1:2)=='-D') then if(arg=='-D') then @@ -335,7 +352,7 @@ subroutine pm_get_command_line(context,mname) pm_opts%ftn_name_types=.false. pm_opts%ftn_name_elems=.false. elseif(pm_main_process) then - write(*,*) 'Not a valid fortran name (-ftn-name-no) option:',trim(arg) + write(*,*) 'Not a valid fortran name (-ftn-no-name) option:',trim(arg) call usage() endif elseif(pm_main_process) then diff --git a/src/parser.f90 b/src/parser.f90 index 506aabe..6aa7090 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -40,7 +40,7 @@ module pm_parser implicit none ! Print out lots of parser debugging info - logical,parameter:: debug_parser=.false. + logical,parameter:: debug_parser=.true. logical,parameter:: debug_parser_extra=.false. ! Check if memory manager attempts to reuse a node @@ -67,6 +67,7 @@ module pm_parser type(pm_ptr),dimension(max_parse_stack):: vstack integer,dimension(max_parse_stack):: vline,vchar integer:: vtop + type(pm_ptr):: op_names integer:: error_count type(pm_reg),pointer:: reg end type parse_state @@ -86,6 +87,7 @@ subroutine init_parser(parser,context) type(pm_context),pointer:: context integer:: i type(pm_ptr)::val + logical:: ok parser%context=>context parser%line(1)=' ' parser%line(2)=' ' @@ -105,7 +107,7 @@ subroutine init_parser(parser,context) parser%reg=>pm_register(context,'parser',& parser%modl,parser%modls,parser%modl_dict,& parser%temp,parser%sysmodl,parser%lexval, & - parser%visibility,& + parser%visibility,parser%op_names,& array=parser%vstack, & array_size=parser%vtop) parser%modl_dict=pm_dict_new(context,128_pm_ln) @@ -113,6 +115,17 @@ subroutine init_parser(parser,context) parser%modls=pm_null_obj parser%visibility=pm_set_new(context,128_pm_ln) parser%vtop=0 + parser%op_names=pm_dict_new(context,int(num_op-min_op+1,pm_ln)) + ! Create dictionary of operator names (for PM__intrinsic) + do i=min_op,num_op +!!$ write(*,*) '@>>',op_names(i),'{',op_names(op_offset_i8),'}',op_long_i8,op_long_i64 + call pm_dict_set(parser%context,parser%op_names,& + pm_new_string(parser%context,trim(op_names(i))),& + pm_fast_tinyint(parser%context,i),& + .true.,.false.,ok) + enddo + contains + include 'ftiny.inc' end subroutine init_parser !====================================================== @@ -175,6 +188,7 @@ subroutine dcl_proc(parser,def,opcode,opcode2,line,flags) if(builtin(parser,opcode,opcode2,pm_null_obj,flags)) then call pm_panic('bad intrinsic module') endif + if(flags/=0) write(*,*) 'FLAGS=',flags end subroutine dcl_proc !====================================================== @@ -407,11 +421,11 @@ subroutine scan(parser) sym=sym_semi case('(') if(peekchar()=='.') then - c=getchar() - sym=sym_open_square - elseif(peekchar()=='%') then c=getchar() sym=sym_open_brace + elseif(peekchar()=='/') then + c=getchar() + sym=sym_open_square else sym=sym_open endif @@ -428,6 +442,9 @@ subroutine scan(parser) if(peekchar()=='>') then c=getchar() sym=sym_arrow + elseif(peekchar()==':') then + c=getchar() + sym=sym_tilde else sym=sym_minus endif @@ -445,8 +462,6 @@ subroutine scan(parser) else sym=sym_pling endif - case('~') - sym=sym_tilde case('/') if(peekchar()=='=') then c=getchar() @@ -454,6 +469,9 @@ subroutine scan(parser) elseif(peekchar()==':') then c=getchar() sym=sym_bar + elseif(peekchar()==')') then + c=getchar() + sym=sym_close_square else sym=sym_divide endif @@ -505,9 +523,6 @@ subroutine scan(parser) elseif(peekchar()==':') then c=getchar() sym=sym_hash - elseif(peekchar()==')') then - c=getchar() - sym=sym_close_brace else sym=sym_pct endif @@ -525,7 +540,7 @@ subroutine scan(parser) sym=sym_d1+iachar(c)-iachar('1') elseif(peekchar()==')') then c=getchar() - sym=sym_close_square + sym=sym_close_brace else sym=sym_dot endif @@ -575,7 +590,12 @@ subroutine scan(parser) sym=sym_dash endif case('&') - sym=sym_amp + if(peekchar()=='&') then + c=getchar() + sym=sym_damp + else + sym=sym_amp + endif case('$') if(peekchar()=='$') then c=getchar() @@ -588,13 +608,13 @@ subroutine scan(parser) ! local character sets and/or keyboards ! Alternatives are available ! ********************************************* - case('[') ! Alternative (. + case('[') ! Alternative (/ sym=sym_open_square - case(']') ! Alternative .) + case(']') ! Alternative /) sym=sym_close_square - case('{') ! Alternative (% + case('{') ! Alternative (. sym=sym_open_brace - case('}') ! Alternative %) + case('}') ! Alternative .) sym=sym_close_brace case('|') ! Alternative /: sym=sym_bar @@ -602,6 +622,8 @@ subroutine scan(parser) sym=sym_at case('#') ! Alternative %: sym=sym_hash + case('~') ! Alternative -: + sym=sym_tilde case('^') ! Only used for internal system purposes if(.not.(parser%modl==parser%sysmodl)) then call parse_error(parser,'Error: Unexpected character "'//c//'"') @@ -1160,10 +1182,11 @@ end function check_name_no_repeat !====================================================== subroutine simple_call(parser) type(parse_state),intent(inout):: parser - call push_null_val(parser) ! keys call push_null_val(parser) ! amps + call push_null_val(parser) ! keys + call push_null_val(parser) ! key names call push_num_val(parser,0) ! flags - call make_node(parser,sym_open,5) + call make_node(parser,sym_open,6) end subroutine simple_call !====================================================== @@ -1201,6 +1224,7 @@ recursive function arglist(parser,object) result(iserr) else flags=0 endif + if(flags/=0) then call push_sym_val(parser,sym_region) call make_node(parser,sym_name,1) @@ -1210,15 +1234,14 @@ recursive function arglist(parser,object) result(iserr) call make_node(parser,sym_name,1) m=3 endif + if(present(object)) then call push_val(parser,object) m=m+1 endif - if(parser%sym/=sym_open) then - if(expect(parser,sym_open)) return - else - call scan(parser) - endif + + if(expect(parser,sym_open)) return + ! Call attributes but no arguments if(parser%sym==sym_open_attr) then if(proc_call_attr(parser,.true.,flags)) return @@ -1226,51 +1249,51 @@ recursive function arglist(parser,object) result(iserr) if(expect(parser,sym_close)) return endif endif + + ! Call with no arguments if(parser%sym==sym_close) then - if(m==0) then - call push_null_val(parser) - else - call make_node(parser,sym_list,m) - endif ! args - call push_null_val(parser) ! keys - call push_null_val(parser) ! amps - call push_num_val(parser,flags) ! flags - call make_node_at(parser,sym_open,5,line,pos) + call make_node(parser,sym_list,m) ! args + call push_null_val(parser) ! amps + call push_null_val(parser) ! keys + call push_null_val(parser) ! key names + call push_num_val(parser,flags) ! flags + call make_node_at(parser,sym_open,6,line,pos) call scan(parser) iserr=.false. return endif + + ! Positional argument do if(parser%sym==sym_amp) then call scan(parser) - if(parser%sym==sym_amp) then - call scan(parser) - if(valref(parser)) return - else - if(valref(parser)) return - call make_node(parser,sym_amp,1) - endif + if(valref(parser)) return m=m+1 call push_sym(parser,m) - elseif(parser%sym==sym_key) then - call make_node(parser,sym_list,m) - exit else if(parser%sym==sym_arg) then - call scan(parser) - if(parser%sym==sym_dotdotdot) then - call push_sym_val(parser,sym_arg) - call make_node(parser,sym_arg,1) - call make_node(parser,sym_dotdotdot,m+1) - call scan(parser) - exit + call push_sym_val(parser,sym_arg) + call make_node(parser,sym_arg,1) + call make_node(parser,sym_dotdotdot,m+1) + if(parser%top>base) then + call name_vector(parser,base) else - call push_back(parser,sym_arg) + call push_null_val(parser) endif + base=parser%top + call scan(parser) + if(expect(parser,sym_dotdotdot)) return + exit else if(check_name(parser,sym)) then if(parser%sym==sym_define) then call make_node(parser,sym_list,m) - call push_name_val(parser,sym) + if(parser%top>base) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif + base=parser%top + call push_sym(parser,sym) call scan(parser) if(expr(parser)) return n=1 @@ -1284,46 +1307,56 @@ recursive function arglist(parser,object) result(iserr) endif if(parser%sym/=sym_comma) then call make_node(parser,sym_list,m) + if(parser%top>base) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif exit endif call scan(parser) enddo + + ! Remaining keyword arguments do while(parser%sym==sym_comma) call scan(parser) - if(parser%sym==sym_key) exit - if(expect_name(parser,& - 'optional argument name')) return + if(check_name(parser,sym)) then + call push_sym(parser,sym) + else + if(expect_name(parser,& + 'keyword argument name')) return + endif if(expect(parser,sym_define,& - 'optional argument "="')) return + 'keyword argument "="')) return if(expr(parser)) return n=n+1 enddo - if(parser%sym==sym_key) then - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - call make_node(parser,sym_dotdotdot,n*2) - else if(n>0) then - call make_node(parser,sym_list,n*2) + + ! List of keyword expressions + if(n>0) then + call make_node(parser,sym_list,n) else call push_null_val(parser) endif - + + ! Vector of keyword names if(parser%top>base) then call name_vector(parser,base) else call push_null_val(parser) endif - + ! Call attributes if present if(parser%sym==sym_open_attr) then if(proc_call_attr(parser,.true.,flags)) return endif call push_num_val(parser,flags) - call make_node_at(parser,sym_open,5,line,pos) + call make_node_at(parser,sym_open,6,line,pos) + if(m+n>pm_max_args) then call parse_error(parser,& - 'Too many arguments to proc call - maximum is:'//pm_maxargs_str) + 'Too many arguments to proc call - maximum is:'//trim(pm_int_as_string(pm_max_args))) endif if(expect(parser,sym_close)) return iserr=.false. @@ -1745,8 +1778,10 @@ recursive function term(parser,checkqual) result(iserr) if(struct_gen(parser)) return case(sym_present) call scan(parser) + if(expect(parser,sym_open)) return if(expect_name(parser)) return call make_node(parser,sym_present,1) + if(expect(parser,sym_close)) return case(sym_number,sym_string) call push_val(parser,parser%lexval) call make_node(parser,sym,1) @@ -1782,45 +1817,19 @@ recursive function term(parser,checkqual) result(iserr) if(typ(parser)) return if(expect(parser,sym_gt)) return call make_node(parser,sym_type_val,1) - case(sym_dash) + case(sym_fix) call scan(parser) - select case(parser%sym) - case(sym_number) - if(pm_fast_vkind(parser%lexval)/=pm_long) then - call parse_error(parser,& - '"''" cannot precede non-default integer constant') - endif - call push_val(parser,parser%lexval) - call scan(parser) - call make_node(parser,sym_dash,1) - case(sym_string) - call push_val(parser,parser%lexval) - call scan(parser) - call make_node(parser,sym_dash,1) - case(sym_true,sym_false) - call push_sym_val(parser,parser%sym) - call scan(parser) - call make_node(parser,sym_dash,1) - case(sym_open) - call scan(parser) - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_fix,1) - case(sym_open_square) + if(parser%sym==sym_open_square) then call push_sym_val(parser,sym_tuple) if(subscript(parser)) return call simple_call(parser) call make_node(parser,sym_fix,1) - case default - if(parser%sym>num_sym) then - call push_val(parser,pm_name_val(parser%context,parser%sym)) - call make_node(parser,sym_dash,1) - call scan(parser) - else - call parse_error(parser,'"''" must be followed by constant value') - return - endif - end select + else + if(expect(parser,sym_open)) return + if(expr(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_fix,1) + endif case(sym_null) if(parser%sym==sym_open) then call scan(parser) @@ -1954,7 +1963,20 @@ end function term recursive function expr(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr - iserr=expr1(parser,100) + integer:: n + iserr=.true. + n=0 + do + if(expr1(parser,100)) return + n=n+1 + if(parser%sym==sym_damp) then + call scan(parser) + else + exit + endif + enddo + if(n>1) call make_node(parser,sym_damp,n) + iserr=.false. end function expr recursive function expr1(parser,priority) result(iserr) @@ -2215,7 +2237,7 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr type(parse_state),intent(inout):: parser logical,intent(in):: call_ok,assign_ok,define_ok logical:: iserr - integer:: n,nu,name + integer:: n,nu,name,m logical:: dotcall,must_be_assignment iserr=.true. n=0 @@ -2230,44 +2252,55 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr nu=nu+1 n=n+1 else - if(expect_name(parser)) return + m=0 n=n+1 - select case(parser%sym) - case(sym_open,sym_pct) - if(n>1.or.nu>0.or..not.call_ok) then - call parse_error(parser,& - 'Unexpected symbol in what seems to be a left hand side expression') - return - endif - if(arglist(parser)) return - call make_node(parser,sym_do,1) - if(parser%sym==sym_comma) then - call parse_error(parser,'Cannot follow a call with a comma') + do + if(expect_name(parser)) return + select case(parser%sym) + case(sym_open,sym_pct) + if(n>1.or.nu>0.or..not.call_ok) then + call parse_error(parser,& + 'Unexpected symbol in what seems to be a left hand side expression') + return + endif + if(arglist(parser)) return + call make_node(parser,sym_do,1) + if(parser%sym==sym_comma) then + call parse_error(parser,'Cannot follow a call with a comma') + return + endif + iserr=.false. return - endif - iserr=.false. - return - case(sym_dot,sym_d1:sym_d7,sym_open_square,sym_at) - must_be_assignment=.true. - dotcall=.false. - call make_node(parser,sym_name,1) - if(qual(parser,dotcall)) return - if(dotcall) then - if(n==1.and.call_ok) then - call make_node(parser,sym_do,1) - if(parser%sym==sym_comma) then - call parse_error(parser,'Cannot follow a call with a comma') + case(sym_dot,sym_d1:sym_d7,sym_open_square,sym_at) + must_be_assignment=.true. + dotcall=.false. + call make_node(parser,sym_name,1) + if(qual(parser,dotcall)) return + if(dotcall) then + if(n==1.and.call_ok) then + call make_node(parser,sym_do,1) + if(parser%sym==sym_comma) then + call parse_error(parser,'Cannot follow a call with a comma') + return + endif + iserr=.false. + return + else + call parse_error(parser,& + 'Unexpected call in what seems to be left hand side expression') return endif - iserr=.false. - return - else - call parse_error(parser,& - 'Unexpected call in what seems to be left hand side expression') - return endif + end select + m=m+1 + if(parser%sym==sym_damp) then + call scan(parser) + must_be_assignment=.true. + else + exit endif - end select + enddo + if(m>1) call make_node(parser,sym_damp,m) select case(parser%sym) case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_xor,sym_concat) call push_sym_val(parser,parser%sym) @@ -2289,13 +2322,13 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr call make_node(parser,sym_define,n) if(expect(parser,sym_define)) return - + if(must_be_assignment.and..not.assign_ok) then call parse_error(parser,'Cannot have an assignment in this context') endif if(rhs(parser,n)) return call make_node(parser,sym_define,2) - + iserr=.false. end function assn_or_call @@ -2342,24 +2375,35 @@ end function rhs recursive function valref(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr + integer:: n iserr=.true. - if(parser%sym==sym_caret) then - call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_caret,1) - else - if(expect_name(parser)) return - if(parser%sym==sym_dash) then + n=0 + do + if(parser%sym==sym_caret) then call scan(parser) + if(expect(parser,sym_open)) return + if(expr(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_caret,1) + else if(expect_name(parser)) return - call make_node(parser,sym_use,2) + if(parser%sym==sym_dash) then + call scan(parser) + if(expect_name(parser)) return + call make_node(parser,sym_use,2) + else + call make_node(parser,sym_name,1) + end if + endif + n=n+1 + if(qual(parser)) return + if(parser%sym==sym_damp) then + call scan(parser) else - call make_node(parser,sym_name,1) - end if - endif - if(qual(parser)) return + exit + endif + enddo + if(n>1) call make_node(parser,sym_damp,n) iserr=.false. end function valref @@ -3763,10 +3807,6 @@ recursive function typunary(parser) result(iserr) call make_node(parser,sym_any,0) if(typunary(parser)) return call make_node(parser,sym_includes,2) - elseif(parser%sym==sym_fix) then - call scan(parser) - if(typunary(parser)) return - call make_node(parser,sym_fix,1) else if(typval(parser)) return endif @@ -3805,23 +3845,42 @@ recursive function typval(parser) result(iserr) case(sym_any) call scan(parser) call make_node(parser,sym_any,0) - case(sym_dash) + case(sym_fix,sym_literal) call scan(parser) - if(parser%sym==sym_number) then - if(pm_fast_vkind(parser%lexval)/=& - pm_long) then - call parse_error(parser,& - 'Cannot have "''" before non-default integer constant') - endif - call push_val(parser,parser%lexval) - call scan(parser) - call make_node(parser,sym_dash,1) - elseif(parser%sym==sym_true.or.parser%sym==sym_false) then - call push_sym_val(parser,parser%sym) - call scan(parser) - call make_node(parser,sym_dash,1) + if(sym==sym_literal.and.parser%sym/=sym_open) then + call make_node(parser,sym_any,0) + call make_node(parser,sym_literal,1) else - call parse_error(parser,'Expected number,"true" or "false"') + if(parser%sym==sym_open) then + call scan(parser) + if(parser%sym==sym_number) then + if(pm_fast_vkind(parser%lexval)/=& + pm_long) then + call parse_error(parser,& + 'Cannot have "fix" before non-default integer constant') + endif + call push_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call scan(parser) + call make_node(parser,sym,1) + elseif(parser%sym==sym_true.or.parser%sym==sym_false) then + call make_node(parser,parser%sym,0) + call scan(parser) + call make_node(parser,sym,1) + elseif(parser%sym==sym_string) then + call push_val(parser,parser%lexval) + call make_node(parser,sym_string,1) + call scan(parser) + call make_node(parser,sym,1) + else + if(typ(parser)) return + call make_node(parser,sym,1) + endif + if(expect(parser,sym_close)) return + else + call push_null_val(parser) + call make_node(parser,sym,1) + endif endif case(sym_dollar) call scan(parser) @@ -4689,7 +4748,7 @@ function proc_decl(parser,method_name,param_base) result(iserr) if(pm_debug_checks) then if(parser%vtop-base/=proc_num_args) then - write(*,*) '=========' + write(*,*) '=========',parser%vtop-base,proc_num_args do flags=base+1,parser%vtop call dump_parse_tree(parser%context,6,parser%vstack(flags),2) write(*,*) '===' @@ -4861,6 +4920,7 @@ recursive function proc_sig(parser) result(iserr) ! Special forms of return type which compute it based on arguments if(parser%sym==sym_arrow) then call scan(parser) + if(expect(parser,sym_open)) return sym=parser%sym select case(sym) case(sym_gt,sym_dim,sym_vdim,sym_invar_dim,sym_fix_dim,& @@ -4876,7 +4936,7 @@ recursive function proc_sig(parser) result(iserr) call make_node(parser,sym,1) case(sym_pct,sym_define,sym_dot,sym_query,sym_amp,& sym_hash,sym_caret,sym_dcaret,sym_d1:sym_d7,sym_invar,sym_shared,& - sym_type,sym_tilde) + sym_type,sym_tilde,sym_damp,sym_bar) ! These return N types based on types of a ! list of N expressions call scan(parser) @@ -4905,6 +4965,7 @@ recursive function proc_sig(parser) result(iserr) call swap_vals(parser) call push_null_val(parser) end select + if(expect(parser,sym_close)) return else call push_num_val(parser,0) call push_null_val(parser) @@ -4914,9 +4975,123 @@ recursive function proc_sig(parser) result(iserr) return end function proc_sig + function builtin_flags(parser,flags) result(iserr) + type(parse_state),intent(inout):: parser + integer,intent(out):: flags + logical:: iserr + iserr=.true. + flags=0 + if(parser%sym==sym_open_attr) then + call scan(parser) + do + select case(parser%sym) + case(sym_proc_is_generator) + flags=ior(flags,proc_is_generator) + case(sym_proc_is_impure) + flags=ior(flags,proc_is_impure) + case(sym_proc_has_for) + flags=ior(flags,proc_has_for) + case(sym_proc_is_dcomm) + flags=ior(flags,proc_is_dcomm) + case(sym_proc_is_file) + flags=ior(flags,proc_is_file) + case(sym_proc_is_not_inlinable) + flags=ior(flags,proc_is_not_inlinable) + case(sym_proc_needs_type) + flags=ior(flags,proc_needs_type) + case default + call parse_error(parser,'Bad PM__intrinsic attribute') + return + end select + call scan(parser) + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + if(expect(parser,sym_close_attr)) return + endif + iserr=.false. + end function builtin_flags + !====================================================== ! Built in procedure definition !====================================================== + function intrinsic(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + type(pm_ptr),target:: ptr + type(pm_ptr)::p,link + type(pm_reg),pointer:: reg + integer:: name,sym,opcode,opcode2,flags + reg=>pm_register(parser%context,'builtin',ptr) + iserr=.true. + + call scan(parser) + if(builtin_flags(parser,flags)) goto 999 + + if(.not.check_name(parser,name)) then + if(op(parser,name,.false.,.false.)) goto 999 + call push_sym_val(parser,name) + else + call push_sym_val(parser,name) + endif + if(parser%sym==sym_pct) then + call scan(parser) + flags=ior(flags,call_is_comm) + endif + + ! Create full name: module!name + call push_sym(parser,& + -get_modl_name(parser%modl)) + ptr=top_val(parser) + name=ptr%offset + call push_sym(parser,name) + call name_vector(parser,parser%top-2) + + ! Link into list of delarations for this name + ptr=decl_entry(parser,int(ptr%offset),modl_proc,link) + call push_val(parser,link) + call push_val(parser,parser%modl) ! module + call push_num_val(parser,flags) ! flags + if(expect(parser,sym_open)) goto 999 + if(proc_sig(parser)) return + + if(expect(parser,sym_colon)) goto 999 + if(expect(parser,sym_string)) goto 999 + p=pm_dict_lookup(parser%context,parser%op_names,parser%lexval) + if(pm_fast_isnull(p)) then + call parse_error(parser,'Bad intrinsic operation'//& + pm_value_as_string(parser%context,parser%lexval)) + goto 999 + endif + opcode=p%offset + + if(parser%sym==sym_open) then + call scan(parser) + if(expect(parser,sym_number)) goto 999 + opcode2=parser%lexval%data%ln(parser%lexval%offset) + if(expect(parser,sym_close)) goto 999 + else + opcode2=0 + endif + + call push_num_val(parser,int(opcode)) + call push_num_val(parser,int(opcode2)) + call push_val(parser,pm_null_obj) + call push_null_val(parser) + call make_node(parser,sym_builtin,sysproc_num_args) + if(debug_parser_extra) then + write(*,*) 'BUILTIN DECL>----------------' + call dump_parse_tree(parser%context,6,top_val(parser),2) + write(*,*) 'BI-DECL-------------' + endif + call add_proc_decl(parser,name,ptr) + iserr=.false. +999 call pm_delete_register(parser%context,reg) + contains + include 'fisnull.inc' + end function intrinsic + + function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) type(parse_state),intent(inout):: parser integer,intent(in):: opcode @@ -4978,6 +5153,7 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) include 'fisnull.inc' end function builtin + !============================================================== ! Add top of stack as declaration of procedure name ! Stack must contain as top 2 entries @@ -5033,7 +5209,7 @@ function typ_decl(parser) result(iserr) if(typ_params(parser,m)) goto 999 params=top_val(parser) - ! <: typelist + ! in typelist if(parser%sym==sym_in) then call scan(parser) if(typ_list(parser,m)) return @@ -5453,11 +5629,13 @@ subroutine decl(parser,is_root_module) integer:: m,sym,name,name2,base,top,kind,line,pos integer:: serror logical:: ok - call push_sym_val(parser,sym_pm_system) - call push_val(parser,parser%sysmodl) - call push_null_val(parser) - call make_node(parser,sym_use,3) - call new_import(parser,sym_pm_system,pop_val(parser)) + if(.not.(parser%modl==parser%sysmodl)) then + call push_sym_val(parser,sym_pm_system) + call push_val(parser,parser%sysmodl) + call push_null_val(parser) + call make_node(parser,sym_use,3) + call new_import(parser,sym_pm_system,pop_val(parser)) + endif do while(parser%sym==sym_use) call use_stmt if(parser%sym==sym_semi) then @@ -5490,6 +5668,24 @@ subroutine decl(parser,is_root_module) if(param_decl(parser)) goto 999 case(sym_test) if(test_stmt(parser)) goto 999 + case(sym_pm_if_compiling) + call scan(parser) + if(.not.pm_is_compiling) then + do while(parser%sym/=sym_pm_else) + call scan(parser) + enddo + call scan(parser) + endif + case(sym_pm_else) + call scan(parser) + do while(parser%sym/=sym_pm_endif) + call scan(parser) + enddo + call scan(parser) + case(sym_pm_endif) + call scan(parser) + case(sym_pm_intrinsic) + if(intrinsic(parser)) goto 999 case default exit end select @@ -6202,12 +6398,12 @@ subroutine parse_error(parser,emess) caret=" " caret(n:n)="!" if(pm_opts%colour) then - write(*,'(3X,A,A67,A)') pm_error_start,caret,pm_error_end + write(*,'(3X,A,A67,A)') pm_opts%error_start,caret,pm_error_end else write(*,'(3X,A67)') caret endif 10 continue - write(*,'(A,A)') trim(pm_opts%error),trim(emess) + write(*,'(A,X,A)') trim(pm_opts%error),trim(emess) endif parser%error_count=parser%error_count+1 if(parser%error_count>max_errors) then diff --git a/src/symbol.f90 b/src/symbol.f90 index a848eeb..fa7aa75 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -66,10 +66,11 @@ module pm_symbol integer,parameter:: sym_caret = 22 integer,parameter:: sym_dcaret = 23 integer,parameter:: sym_dcolon = 24 - integer,parameter:: sym_define = 25 - integer,parameter:: sym_cond = 26 - integer,parameter:: sym_string = 27 - integer,parameter:: sym_number = 28 + integer,parameter:: sym_damp = 25 + integer,parameter:: sym_define = 26 + integer,parameter:: sym_cond = 27 + integer,parameter:: sym_string = 28 + integer,parameter:: sym_number = 29 ! Operators integer,parameter:: sym1 = sym_number @@ -228,7 +229,11 @@ module pm_symbol integer,parameter:: sym_pm_head_node = last_resv + 14 integer,parameter:: sym_pm_do_at = last_resv + 15 integer,parameter:: sym_pm_do = last_resv + 16 - integer,parameter:: last_stmt = sym_pm_do + integer,parameter:: sym_pm_intrinsic = last_resv + 17 + integer,parameter:: sym_pm_if_compiling = last_resv + 18 + integer,parameter:: sym_pm_else = last_resv + 19 + integer,parameter:: sym_pm_endif = last_resv + 20 + integer,parameter:: last_stmt = sym_pm_endif integer,parameter:: num_sym = last_stmt ! Non-reserved words that the compiler needs to know about @@ -257,9 +262,21 @@ module pm_symbol ! filesystem integer,parameter:: sym_filesystem = num_sym + 18 + + ! Attributes for intrinsics + integer,parameter:: sym_proc_is_generator = num_sym + 19 + integer,parameter:: sym_proc_is_impure = num_sym + 20 + integer,parameter:: sym_proc_has_for = num_sym + 21 + integer,parameter:: sym_proc_is_dcomm = num_sym + 22 + integer,parameter:: sym_proc_is_file = num_sym + 23 + integer,parameter:: sym_proc_is_not_inlinable = num_sym + 24 + integer,parameter:: sym_proc_needs_type = num_sym + 25 + + ! Specialised types + integer,parameter:: sym_literal = num_sym + 26 ! Symbols used as node types (actual name not really used) - integer,parameter:: node0 = num_sym + 18 + integer,parameter:: node0 = num_sym + 26 integer,parameter:: sym_iter = node0 + 1 integer,parameter:: sym_list = node0 + 2 integer,parameter:: sym_builtin = node0 + 3 @@ -495,6 +512,7 @@ module pm_symbol data sym_names(sym_caret) /'^'/ data sym_names(sym_dcaret) /'^^'/ data sym_names(sym_dcolon) /'::'/ + data sym_names(sym_damp) /'&&'/ data sym_names(sym_define) /'='/ data sym_names(sym_cond) /'=>'/ @@ -636,6 +654,10 @@ module pm_symbol data sym_names(sym_pm_head_node) /'PM__head_node'/ data sym_names(sym_pm_do_at) /'PM__do_at'/ data sym_names(sym_pm_do) /'PM__do'/ + data sym_names(sym_pm_intrinsic) /'PM__intrinsic'/ + data sym_names(sym_pm_if_compiling) /'PM__if_compiling'/ + data sym_names(sym_pm_else) /'PM__else'/ + data sym_names(sym_pm_endif) /'PM__endif'/ !=============================================================== @@ -661,9 +683,19 @@ module pm_symbol data sym_names(sym_filesystem) /'filesystem'/ + data sym_names(sym_proc_is_generator) /'is_generator'/ + data sym_names(sym_proc_is_impure) /'is_impure'/ + data sym_names(sym_proc_has_for) /'has_for'/ + data sym_names(sym_proc_is_dcomm) /'is_dcomm'/ + data sym_names(sym_proc_is_file) /'is_file'/ + data sym_names(sym_proc_is_not_inlinable) /'is_not_inlinable'/ + data sym_names(sym_proc_needs_type) /'needs_type'/ + + data sym_names(sym_literal) /'literal'/ + ! Symbols that are node names only data sym_names(sym_iter) /''/ - data sym_names(sym_list) /''/ + data sym_names(sym_list) /'list'/ data sym_names(sym_builtin) /''/ data sym_names(sym_each_proc) /''/ data sym_names(sym_mode) /''/ diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index f098f2a..d0988cf 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -14,7 +14,6 @@ ! ! The above copyright notice and this permission notice shall be included in ! all copies or substantial portions of the Software. -! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -44,86 +43,100 @@ module pm_sysdefs subroutine sysdefs(parser) type(parse_state):: parser integer:: line + logical:: ok + line=1 call dcl_module(parser,'PM__system') parser%sysmodl=parser%modl + call pm_open_file(3,'sysmod.pmm',ok) + if(.not.ok) then + if(pm_main_process) then + write(*,*) 'Cannot open sysmod.pmm' + endif + call pm_stop('Compilation terminated') + endif + !write(*,*) 'Parsing',trim(str) + call parse_file_on_unit(parser,3,.false.) + close(3) + return + call dcl_type(parser,'literal is ^^^any',line) call dcl_type(parser,'int_literal is ^^^int',line) call dcl_type(parser,'real_literal is ^^^real',line) call dcl_type(parser,'bool_literal is ^^^bool',line) call dcl_type(parser,'string_literal is ^^^string',line) - call dcl_proc(parser,'mod(int_literal,int_literal)->int_literal',op_mod_fold,0,line,0) - call dcl_proc(parser,'==(int_literal,int_literal)->bool_literal',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(int_literal,int_literal)->bool_literal',op_ne_fold,0,line,0) - call dcl_proc(parser,'>=(int_literal,int_literal)->bool_literal',op_ge_fold,0,line,0) - call dcl_proc(parser,'>(int_literal,int_literal)->bool_literal',op_gt_fold,0,line,0) - call dcl_proc(parser,'+(int_literal,int_literal)->int_literal',op_add_fold,0,line,0) - call dcl_proc(parser,'-(int_literal,int_literal)->int_literal',op_sub_fold,0,line,0) - call dcl_proc(parser,'*(int_literal,int_literal)->int_literal',op_mult_fold,0,line,0) - call dcl_proc(parser,'/(int_literal,int_literal)->int_literal',op_divide_fold,0,line,0) - call dcl_proc(parser,'**(int_literal,int_literal)->int_literal',op_pow_fold,0,line,0) - call dcl_proc(parser,'max(int_literal,int_literal)->int_literal',op_max_fold,0,line,0) - call dcl_proc(parser,'min(int_literal,int_literal)->int_literal',op_min_fold,0,line,0) - call dcl_proc(parser,'-(int_literal)->int_literal',op_uminus_fold,0,line,0) - call dcl_proc(parser,'string(int_literal)->string',op_string_fold,0,line,0) - call dcl_proc(parser,'abs(int_literal)->int_literal',op_abs_fold,0,line,0) - call dcl_proc(parser,'~(int_literal)->int_literal',op_bnot_fold,0,line,0) - call dcl_proc(parser,'&(int_literal,int_literal)->int_literal',op_band_fold,0,line,0) - call dcl_proc(parser,'|(int_literal,int_literal)->int_literal',op_bor_fold,0,line,0) - call dcl_proc(parser,'xor(int_literal,int_literal)->int_literal',op_bxor_fold,0,line,0) - call dcl_proc(parser,'shift(int_literal,int_literal)->int_literal',& + call dcl_proc(parser,'mod(int_literal,int_literal)->(int_literal)',op_mod_fold,0,line,0) + call dcl_proc(parser,'==(int_literal,int_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(int_literal,int_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'>=(int_literal,int_literal)->(bool_literal)',op_ge_fold,0,line,0) + call dcl_proc(parser,'>(int_literal,int_literal)->(bool_literal)',op_gt_fold,0,line,0) + call dcl_proc(parser,'+(int_literal,int_literal)->(int_literal)',op_add_fold,0,line,0) + call dcl_proc(parser,'-(int_literal,int_literal)->(int_literal)',op_sub_fold,0,line,0) + call dcl_proc(parser,'*(int_literal,int_literal)->(int_literal)',op_mult_fold,0,line,0) + call dcl_proc(parser,'/(int_literal,int_literal)->(int_literal)',op_divide_fold,0,line,0) + call dcl_proc(parser,'**(int_literal,int_literal)->(int_literal)',op_pow_fold,0,line,0) + call dcl_proc(parser,'max(int_literal,int_literal)->(int_literal)',op_max_fold,0,line,0) + call dcl_proc(parser,'min(int_literal,int_literal)->(int_literal)',op_min_fold,0,line,0) + call dcl_proc(parser,'-(int_literal)->(int_literal)',op_uminus_fold,0,line,0) + call dcl_proc(parser,'string(int_literal)->(string)',op_string_fold,0,line,0) + call dcl_proc(parser,'abs(int_literal)->(int_literal)',op_abs_fold,0,line,0) + call dcl_proc(parser,'~(int_literal)->(int_literal)',op_bnot_fold,0,line,0) + call dcl_proc(parser,'&(int_literal,int_literal)->(int_literal)',op_band_fold,0,line,0) + call dcl_proc(parser,'|(int_literal,int_literal)->(int_literal)',op_bor_fold,0,line,0) + call dcl_proc(parser,'xor(int_literal,int_literal)->(int_literal)',op_bxor_fold,0,line,0) + call dcl_proc(parser,'shift(int_literal,int_literal)->(int_literal)',& op_bshift_fold,0,line,0) - call dcl_proc(parser,'pdiff(int_literal,int_literal)->int_literal',op_pdiff_fold,0,line,0) - call dcl_proc(parser,'sign(int_literal,int_literal)->int_literal',op_sign_fold,0,line,0) - call dcl_proc(parser,'rem(int_literal,int_literal)->int_literal',op_modulo_fold,0,line,0) - call dcl_proc(parser,'and(bool_literal,bool_literal)->bool_literal',op_and_fold,0,line,0) - call dcl_proc(parser,'or(bool_literal,bool_literal)->bool_literal',op_or_fold,0,line,0) - call dcl_proc(parser,'except(bool_literal,bool_literal)->bool_literal',op_except_fold,0,line,0) - call dcl_proc(parser,'==(bool_literal,bool_literal)->bool_literal',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(bool_literal,bool_literal)->bool_literal',op_ne_fold,0,line,0) - call dcl_proc(parser,'==(string_literal,string_literal)->bool_literal',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(string_literal,string_literal)->bool_literal',op_ne_fold,0,line,0) - call dcl_proc(parser,'==(real_literal,real_literal)->bool_literal',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(real_literal,real_literal)->bool_literal',op_ne_fold,0,line,0) - call dcl_proc(parser,'++(string_literal,string_literal)->string_literal',op_concat_fold,0,line,0) - - call dcl_proc(parser,'mod(fix int,fix int)->fix int',op_mod_fold,0,line,0) - call dcl_proc(parser,'==(fix int,fix int)->fix bool',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(fix int,fix int)->fix bool',op_ne_fold,0,line,0) - call dcl_proc(parser,'>=(fix int,fix int)->fix bool',op_ge_fold,0,line,0) - call dcl_proc(parser,'>(fix int,fix int)->fix bool',op_gt_fold,0,line,0) - call dcl_proc(parser,'+(fix int,fix int)->fix int',op_add_fold,0,line,0) - call dcl_proc(parser,'-(fix int,fix int)->fix int',op_sub_fold,0,line,0) - call dcl_proc(parser,'*(fix int,fix int)->fix int',op_mult_fold,0,line,0) - call dcl_proc(parser,'/(fix int,fix int)->fix int',op_divide_fold,0,line,0) - call dcl_proc(parser,'**(fix int,fix int)->fix int',op_pow_fold,0,line,0) - call dcl_proc(parser,'max(fix int,fix int)->fix int',op_max_fold,0,line,0) - call dcl_proc(parser,'min(fix int,fix int)->fix int',op_min_fold,0,line,0) - call dcl_proc(parser,'-(fix int)->fix int',op_uminus_fold,0,line,0) - call dcl_proc(parser,'string(fix int)->string',op_string_fold,0,line,0) - call dcl_proc(parser,'abs(fix int)->fix int',op_abs_fold,0,line,0) - call dcl_proc(parser,'~(fix int)->fix int',op_bnot_fold,0,line,0) - call dcl_proc(parser,'&(fix int,fix int)->fix int',op_band_fold,0,line,0) - call dcl_proc(parser,'|(fix int,fix int)->fix int',op_bor_fold,0,line,0) - call dcl_proc(parser,'xor(fix int,fix int)->fix int',op_bxor_fold,0,line,0) - call dcl_proc(parser,'shift(fix int,fix int)->fix int',& + call dcl_proc(parser,'pdiff(int_literal,int_literal)->(int_literal)',op_pdiff_fold,0,line,0) + call dcl_proc(parser,'sign(int_literal,int_literal)->(int_literal)',op_sign_fold,0,line,0) + call dcl_proc(parser,'rem(int_literal,int_literal)->(int_literal)',op_modulo_fold,0,line,0) + call dcl_proc(parser,'and(bool_literal,bool_literal)->(bool_literal)',op_and_fold,0,line,0) + call dcl_proc(parser,'or(bool_literal,bool_literal)->(bool_literal)',op_or_fold,0,line,0) + call dcl_proc(parser,'except(bool_literal,bool_literal)->(bool_literal)',op_except_fold,0,line,0) + call dcl_proc(parser,'==(bool_literal,bool_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(bool_literal,bool_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(string_literal,string_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(string_literal,string_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(real_literal,real_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(real_literal,real_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'++(string_literal,string_literal)->(string_literal)',op_concat_fold,0,line,0) + + call dcl_proc(parser,'mod(fix int,fix int)->(fix int)',op_mod_fold,0,line,0) + call dcl_proc(parser,'==(fix int,fix int)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix int,fix int)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'>=(fix int,fix int)->(fix bool)',op_ge_fold,0,line,0) + call dcl_proc(parser,'>(fix int,fix int)->(fix bool)',op_gt_fold,0,line,0) + call dcl_proc(parser,'+(fix int,fix int)->(fix int)',op_add_fold,0,line,0) + call dcl_proc(parser,'-(fix int,fix int)->(fix int)',op_sub_fold,0,line,0) + call dcl_proc(parser,'*(fix int,fix int)->(fix int)',op_mult_fold,0,line,0) + call dcl_proc(parser,'/(fix int,fix int)->(fix int)',op_divide_fold,0,line,0) + call dcl_proc(parser,'**(fix int,fix int)->(fix int)',op_pow_fold,0,line,0) + call dcl_proc(parser,'max(fix int,fix int)->(fix int)',op_max_fold,0,line,0) + call dcl_proc(parser,'min(fix int,fix int)->(fix int)',op_min_fold,0,line,0) + call dcl_proc(parser,'-(fix int)->(fix int)',op_uminus_fold,0,line,0) + call dcl_proc(parser,'string(fix int)->(string)',op_string_fold,0,line,0) + call dcl_proc(parser,'abs(fix int)->(fix int)',op_abs_fold,0,line,0) + call dcl_proc(parser,'~(fix int)->(fix int)',op_bnot_fold,0,line,0) + call dcl_proc(parser,'&(fix int,fix int)->(fix int)',op_band_fold,0,line,0) + call dcl_proc(parser,'|(fix int,fix int)->(fix int)',op_bor_fold,0,line,0) + call dcl_proc(parser,'xor(fix int,fix int)->(fix int)',op_bxor_fold,0,line,0) + call dcl_proc(parser,'shift(fix int,fix int)->(fix int)',& op_bshift_fold,0,line,0) - call dcl_proc(parser,'pdiff(fix int,fix int)->fix int',op_pdiff_fold,0,line,0) - call dcl_proc(parser,'sign(fix int,fix int)->fix int',op_sign_fold,0,line,0) - call dcl_proc(parser,'rem(fix int,fix int)->fix int',op_modulo_fold,0,line,0) - call dcl_proc(parser,'and(fix bool,fix bool)->fix bool',op_and_fold,0,line,0) - call dcl_proc(parser,'or(fix bool,fix bool)->fix bool',op_or_fold,0,line,0) - call dcl_proc(parser,'except(fix bool,fix bool)->fix bool',op_except_fold,0,line,0) - call dcl_proc(parser,'==(fix bool,fix bool)->fix bool',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(fix bool,fix bool)->fix bool',op_ne_fold,0,line,0) - call dcl_proc(parser,'==(fix string,fix string)->fix bool',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(fix string,fix string)->fix bool',op_ne_fold,0,line,0) - call dcl_proc(parser,'==(fix real,fix real)->fix bool',op_eq_fold,0,line,0) - call dcl_proc(parser,'/=(fix real,fix real)->fix bool',op_ne_fold,0,line,0) - call dcl_proc(parser,'++(fix string,fix string)->fix string',op_concat_fold,0,line,0) + call dcl_proc(parser,'pdiff(fix int,fix int)->(fix int)',op_pdiff_fold,0,line,0) + call dcl_proc(parser,'sign(fix int,fix int)->(fix int)',op_sign_fold,0,line,0) + call dcl_proc(parser,'rem(fix int,fix int)->(fix int)',op_modulo_fold,0,line,0) + call dcl_proc(parser,'and(fix bool,fix bool)->(fix bool)',op_and_fold,0,line,0) + call dcl_proc(parser,'or(fix bool,fix bool)->(fix bool)',op_or_fold,0,line,0) + call dcl_proc(parser,'except(fix bool,fix bool)->(fix bool)',op_except_fold,0,line,0) + call dcl_proc(parser,'==(fix bool,fix bool)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix bool,fix bool)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(fix string,fix string)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix string,fix string)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(fix real,fix real)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix real,fix real)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'++(fix string,fix string)->(fix string)',op_concat_fold,0,line,0) ! ************************************** ! BASIC TYPES @@ -134,7 +147,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'print(x) { print(string(x)) }',line) call dcl_proc(parser,'print_all(string)',op_print,1,line,proc_is_impure) call dcl_uproc(parser,'print_all(x) { print_all(string(x)) }',line) - call dcl_proc(parser,'++(string,string)->string',op_concat,0,line,0) + call dcl_proc(parser,'++(string,string)->(string)',op_concat,0,line,0) call dcl_uproc(parser,'++(x:string,y)=$++.(x,string(y))',line) call dcl_uproc(parser,'++(x,y)=$++.(string(x),string(y))',line) call dcl_uproc(parser,'string(x:string)=x',line) @@ -144,469 +157,469 @@ subroutine sysdefs(parser) ! sint type call dcl_proc(parser,'PM__assign_var(&sint,sint)',& op_assign_i,0,line,0) - call dcl_proc(parser,'mod(sint,sint)->sint',op_mod_i,0,line,0) - call dcl_proc(parser,'==(sint,sint)->bool',op_eq_i,0,line,0) - call dcl_proc(parser,'/=(sint,sint)->bool',op_ne_i,0,line,0) - call dcl_proc(parser,'>=(sint,sint)->bool',op_ge_i,0,line,0) - call dcl_proc(parser,'>(sint,sint)->bool',op_gt_i,0,line,0) - call dcl_proc(parser,'+(sint,sint)->sint',op_add_i,0,line,0) - call dcl_proc(parser,'-(sint,sint)->sint',op_sub_i,0,line,0) - call dcl_proc(parser,'*(sint,sint)->sint',op_mult_i,0,line,0) - call dcl_proc(parser,'/(sint,sint)->sint',op_divide_i,0,line,0) - call dcl_proc(parser,'**(sint,sint)->sint',op_pow_i,0,line,0) - call dcl_proc(parser,'max(sint,sint)->sint',op_max_i,0,line,0) - call dcl_proc(parser,'min(sint,sint)->sint',op_min_i,0,line,0) - call dcl_proc(parser,'-(sint)->sint',op_uminus_i,0,line,0) - call dcl_proc(parser,'string(sint)->string',op_string_i,0,line,0) - call dcl_proc(parser,'int(sint)->int',op_long_i,0,line,0) - call dcl_proc(parser,'sreal(sint)->sreal',op_real_i,0,line,0) - call dcl_proc(parser,'real(sint)->real',op_double_i,0,line,0) + call dcl_proc(parser,'mod(sint,sint)->(sint)',op_mod_i,0,line,0) + call dcl_proc(parser,'==(sint,sint)->(bool)',op_eq_i,0,line,0) + call dcl_proc(parser,'/=(sint,sint)->(bool)',op_ne_i,0,line,0) + call dcl_proc(parser,'>=(sint,sint)->(bool)',op_ge_i,0,line,0) + call dcl_proc(parser,'>(sint,sint)->(bool)',op_gt_i,0,line,0) + call dcl_proc(parser,'+(sint,sint)->(sint)',op_add_i,0,line,0) + call dcl_proc(parser,'-(sint,sint)->(sint)',op_sub_i,0,line,0) + call dcl_proc(parser,'*(sint,sint)->(sint)',op_mult_i,0,line,0) + call dcl_proc(parser,'/(sint,sint)->(sint)',op_divide_i,0,line,0) + call dcl_proc(parser,'**(sint,sint)->(sint)',op_pow_i,0,line,0) + call dcl_proc(parser,'max(sint,sint)->(sint)',op_max_i,0,line,0) + call dcl_proc(parser,'min(sint,sint)->(sint)',op_min_i,0,line,0) + call dcl_proc(parser,'-(sint)->(sint)',op_uminus_i,0,line,0) + call dcl_proc(parser,'string(sint)->(string)',op_string_i,0,line,0) + call dcl_proc(parser,'int(sint)->(int)',op_long_i,0,line,0) + call dcl_proc(parser,'sreal(sint)->(sreal)',op_real_i,0,line,0) + call dcl_proc(parser,'real(sint)->(real)',op_double_i,0,line,0) call dcl_uproc(parser,'sint(x:sint)=x',line) - call dcl_proc(parser,'abs(sint)->sint',op_abs_i,0,line,0) - call dcl_proc(parser,'bit_not(sint)->sint',op_bnot_i,0,line,0) - call dcl_proc(parser,'&(sint,sint)->sint',op_band_i,0,line,0) - call dcl_proc(parser,'|(sint,sint)->sint',op_bor_i,0,line,0) - call dcl_proc(parser,'xor(sint,sint)->sint',op_bxor_i,0,line,0) - call dcl_proc(parser,'shift(sint,sint)->sint',op_bshift_i,0,line,0) - call dcl_proc(parser,'pdiff(sint,sint)->sint',op_pdiff_i,0,line,0) - call dcl_proc(parser,'sign(sint,sint)->sint',op_sign_i,0,line,0) - call dcl_proc(parser,'rem(sint,sint)->sint',op_modulo_i,0,line,0) - call dcl_proc(parser,'int8(sint)->int8',op_i8_i,0,line,0) - call dcl_proc(parser,'int16(sint)->int16',op_i16_i,0,line,0) - call dcl_proc(parser,'int32(sint)->int32',op_i32_i,0,line,0) - call dcl_proc(parser,'int64(sint)->int64',op_i64_i,0,line,0) - call dcl_proc(parser,'lint(sint)->lint',op_offset_i,0,line,0) + call dcl_proc(parser,'abs(sint)->(sint)',op_abs_i,0,line,0) + call dcl_proc(parser,'bit_not(sint)->(sint)',op_bnot_i,0,line,0) + call dcl_proc(parser,'&(sint,sint)->(sint)',op_band_i,0,line,0) + call dcl_proc(parser,'|(sint,sint)->(sint)',op_bor_i,0,line,0) + call dcl_proc(parser,'xor(sint,sint)->(sint)',op_bxor_i,0,line,0) + call dcl_proc(parser,'shift(sint,sint)->(sint)',op_bshift_i,0,line,0) + call dcl_proc(parser,'pdiff(sint,sint)->(sint)',op_pdiff_i,0,line,0) + call dcl_proc(parser,'sign(sint,sint)->(sint)',op_sign_i,0,line,0) + call dcl_proc(parser,'rem(sint,sint)->(sint)',op_modulo_i,0,line,0) + call dcl_proc(parser,'int8(sint)->(int8)',op_i8_i,0,line,0) + call dcl_proc(parser,'int16(sint)->(int16)',op_i16_i,0,line,0) + call dcl_proc(parser,'int32(sint)->(int32)',op_i32_i,0,line,0) + call dcl_proc(parser,'int64(sint)->(int64)',op_i64_i,0,line,0) + call dcl_proc(parser,'lint(sint)->(lint)',op_offset_i,0,line,0) ! int type call dcl_proc(parser,'PM__assign_var(&int,int)',& op_assign_ln,0,line,0) - call dcl_proc(parser,'mod(int,int)->int',op_mod_ln,0,line,0) - call dcl_proc(parser,'==(int,int)->bool',op_eq_ln,0,line,0) - call dcl_proc(parser,'/=(int,int)->bool',op_ne_ln,0,line,0) - call dcl_proc(parser,'>=(int,int)->bool',op_ge_ln,0,line,0) - call dcl_proc(parser,'>(int,int)->bool',op_gt_ln,0,line,0) - call dcl_proc(parser,'+(int,int)->int',op_add_ln,0,line,0) + call dcl_proc(parser,'mod(int,int)->(int)',op_mod_ln,0,line,0) + call dcl_proc(parser,'==(int,int)->(bool)',op_eq_ln,0,line,0) + call dcl_proc(parser,'/=(int,int)->(bool)',op_ne_ln,0,line,0) + call dcl_proc(parser,'>=(int,int)->(bool)',op_ge_ln,0,line,0) + call dcl_proc(parser,'>(int,int)->(bool)',op_gt_ln,0,line,0) + call dcl_proc(parser,'+(int,int)->(int)',op_add_ln,0,line,0) !!$ call dcl_uproc(parser,'+(x:int,y:''0)=x',line) !!$ call dcl_uproc(parser,'+(x:''0,y:int)=y',line) - call dcl_proc(parser,'-(int,int)->int',op_sub_ln,0,line,0) + call dcl_proc(parser,'-(int,int)->(int)',op_sub_ln,0,line,0) !!$ call dcl_uproc(parser,'-(x:int,y:''0)=x',line) - call dcl_proc(parser,'*(int,int)->int',op_mult_ln,0,line,0) + call dcl_proc(parser,'*(int,int)->(int)',op_mult_ln,0,line,0) call dcl_uproc(parser,'*(x:int,y:''1)=x',line) !!$ call dcl_uproc(parser,'*(x:''1,y:int)=y',line) - call dcl_proc(parser,'/(int,int)->int',op_divide_ln,0,line,0) + call dcl_proc(parser,'/(int,int)->(int)',op_divide_ln,0,line,0) call dcl_uproc(parser,'/(x:int,y:''1)=x',line) - call dcl_proc(parser,'**(int,int)->int',op_pow_ln,0,line,0) + call dcl_proc(parser,'**(int,int)->(int)',op_pow_ln,0,line,0) !!$ call dcl_uproc(parser,'**(x:int,y:''0)=1',line) !!$ call dcl_uproc(parser,'**(x:int,y:''1)=x',line) !!$ call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) - call dcl_proc(parser,'max(int,int)->int',op_max_ln,0,line,0) - call dcl_proc(parser,'min(int,int)->int',op_min_ln,0,line,0) - call dcl_proc(parser,'-(int)->int',op_uminus_ln,0,line,0) - call dcl_proc(parser,'string(int)->string',op_string_ln,0,line,0) - call dcl_proc(parser,'sint(int)->sint',op_int_ln,0,line,0) - call dcl_proc(parser,'sreal(int)->sreal',op_real_ln,0,line,0) - call dcl_proc(parser,'real(int)->real',op_double_ln,0,line,0) + call dcl_proc(parser,'max(int,int)->(int)',op_max_ln,0,line,0) + call dcl_proc(parser,'min(int,int)->(int)',op_min_ln,0,line,0) + call dcl_proc(parser,'-(int)->(int)',op_uminus_ln,0,line,0) + call dcl_proc(parser,'string(int)->(string)',op_string_ln,0,line,0) + call dcl_proc(parser,'sint(int)->(sint)',op_int_ln,0,line,0) + call dcl_proc(parser,'sreal(int)->(sreal)',op_real_ln,0,line,0) + call dcl_proc(parser,'real(int)->(real)',op_double_ln,0,line,0) call dcl_uproc(parser,'int(x:int)=x',line) - call dcl_proc(parser,'abs(int)->int',op_abs_ln,0,line,0) - call dcl_proc(parser,'~(int)->int',op_bnot_ln,0,line,0) - call dcl_proc(parser,'&(int,int)->int',op_band_ln,0,line,0) - call dcl_proc(parser,'|(int,int)->int',op_bor_ln,0,line,0) - call dcl_proc(parser,'xor(int,int)->int',op_bxor_ln,0,line,0) - call dcl_proc(parser,'shift(int,int)->int',& + call dcl_proc(parser,'abs(int)->(int)',op_abs_ln,0,line,0) + call dcl_proc(parser,'~(int)->(int)',op_bnot_ln,0,line,0) + call dcl_proc(parser,'&(int,int)->(int)',op_band_ln,0,line,0) + call dcl_proc(parser,'|(int,int)->(int)',op_bor_ln,0,line,0) + call dcl_proc(parser,'xor(int,int)->(int)',op_bxor_ln,0,line,0) + call dcl_proc(parser,'shift(int,int)->(int)',& op_bshift_ln,0,line,0) - call dcl_proc(parser,'pdiff(int,int)->int',op_pdiff_ln,0,line,0) - call dcl_proc(parser,'sign(int,int)->int',op_sign_ln,0,line,0) - call dcl_proc(parser,'rem(int,int)->int',op_modulo_ln,0,line,0) - call dcl_proc(parser,'int8(int)->int8',op_i8_ln,0,line,0) - call dcl_proc(parser,'int16(int)->int16',op_i16_ln,0,line,0) - call dcl_proc(parser,'int32(int)->int32',op_i32_ln,0,line,0) - call dcl_proc(parser,'int64(int)->int64',op_i64_ln,0,line,0) - call dcl_proc(parser,'lint(int)->lint',op_offset_ln,0,line,0) + call dcl_proc(parser,'pdiff(int,int)->(int)',op_pdiff_ln,0,line,0) + call dcl_proc(parser,'sign(int,int)->(int)',op_sign_ln,0,line,0) + call dcl_proc(parser,'rem(int,int)->(int)',op_modulo_ln,0,line,0) + call dcl_proc(parser,'int8(int)->(int8)',op_i8_ln,0,line,0) + call dcl_proc(parser,'int16(int)->(int16)',op_i16_ln,0,line,0) + call dcl_proc(parser,'int32(int)->(int32)',op_i32_ln,0,line,0) + call dcl_proc(parser,'int64(int)->(int64)',op_i64_ln,0,line,0) + call dcl_proc(parser,'lint(int)->(lint)',op_offset_ln,0,line,0) ! lint type call dcl_proc(parser,'PM__assign_var(&lint,lint)',& op_assign_offset,0,line,0) - call dcl_proc(parser,'mod(lint,lint)->lint',op_mod_offset,0,line,0) - call dcl_proc(parser,'==(lint,lint)->bool',op_eq_offset,0,line,0) - call dcl_proc(parser,'/=(lint,lint)->bool',op_ne_offset,0,line,0) - call dcl_proc(parser,'>=(lint,lint)->bool',op_ge_offset,0,line,0) - call dcl_proc(parser,'>(lint,lint)->bool',op_gt_offset,0,line,0) - call dcl_proc(parser,'+(lint,lint)->lint',op_add_offset,0,line,0) + call dcl_proc(parser,'mod(lint,lint)->(lint)',op_mod_offset,0,line,0) + call dcl_proc(parser,'==(lint,lint)->(bool)',op_eq_offset,0,line,0) + call dcl_proc(parser,'/=(lint,lint)->(bool)',op_ne_offset,0,line,0) + call dcl_proc(parser,'>=(lint,lint)->(bool)',op_ge_offset,0,line,0) + call dcl_proc(parser,'>(lint,lint)->(bool)',op_gt_offset,0,line,0) + call dcl_proc(parser,'+(lint,lint)->(lint)',op_add_offset,0,line,0) call dcl_uproc(parser,'+(x:lint,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:lint)=y',line) - call dcl_proc(parser,'-(lint,lint)->lint',op_sub_offset,0,line,0) + call dcl_proc(parser,'-(lint,lint)->(lint)',op_sub_offset,0,line,0) call dcl_uproc(parser,'-(x:lint,y:''0)=x',line) - call dcl_proc(parser,'*(lint,lint)->lint',op_mult_offset,0,line,0) + call dcl_proc(parser,'*(lint,lint)->(lint)',op_mult_offset,0,line,0) call dcl_uproc(parser,'*(x:lint,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:lint)=y',line) - call dcl_proc(parser,'/(lint,lint)->lint',op_divide_offset,0,line,0) + call dcl_proc(parser,'/(lint,lint)->(lint)',op_divide_offset,0,line,0) call dcl_uproc(parser,'/(x:lint,y:''1)=x',line) - call dcl_proc(parser,'**(lint,lint)->lint',op_pow_offset,0,line,0) + call dcl_proc(parser,'**(lint,lint)->(lint)',op_pow_offset,0,line,0) call dcl_uproc(parser,'**(x:lint,y:''0)=1',line) call dcl_uproc(parser,'**(x:lint,y:''1)=x',line) call dcl_uproc(parser,'**(x:lint,y:''2)=x*x',line) - call dcl_proc(parser,'max(lint,lint)->lint',op_max_offset,0,line,0) - call dcl_proc(parser,'min(lint,lint)->lint',op_min_offset,0,line,0) - call dcl_proc(parser,'-(lint)->lint',op_uminus_offset,0,line,0) - call dcl_proc(parser,'string(lint)->string',op_string_offset,0,line,0) - call dcl_proc(parser,'sint(lint)->sint',op_int_offset,0,line,0) - call dcl_proc(parser,'sreal(lint)->sreal',op_real_offset,0,line,0) - call dcl_proc(parser,'real(lint)->real',op_double_offset,0,line,0) + call dcl_proc(parser,'max(lint,lint)->(lint)',op_max_offset,0,line,0) + call dcl_proc(parser,'min(lint,lint)->(lint)',op_min_offset,0,line,0) + call dcl_proc(parser,'-(lint)->(lint)',op_uminus_offset,0,line,0) + call dcl_proc(parser,'string(lint)->(string)',op_string_offset,0,line,0) + call dcl_proc(parser,'sint(lint)->(sint)',op_int_offset,0,line,0) + call dcl_proc(parser,'sreal(lint)->(sreal)',op_real_offset,0,line,0) + call dcl_proc(parser,'real(lint)->(real)',op_double_offset,0,line,0) call dcl_uproc(parser,'lint(x:lint)=x',line) - call dcl_proc(parser,'abs(lint)->lint',op_abs_offset,0,line,0) - call dcl_proc(parser,'~(lint)->lint',op_bnot_offset,0,line,0) - call dcl_proc(parser,'&(lint,lint)->lint',op_band_offset,0,line,0) - call dcl_proc(parser,'|(lint,lint)->lint',op_bor_offset,0,line,0) - call dcl_proc(parser,'xor(lint,lint)->lint',op_bxor_offset,0,line,0) - call dcl_proc(parser,'shift(lint,lint)->lint',& + call dcl_proc(parser,'abs(lint)->(lint)',op_abs_offset,0,line,0) + call dcl_proc(parser,'~(lint)->(lint)',op_bnot_offset,0,line,0) + call dcl_proc(parser,'&(lint,lint)->(lint)',op_band_offset,0,line,0) + call dcl_proc(parser,'|(lint,lint)->(lint)',op_bor_offset,0,line,0) + call dcl_proc(parser,'xor(lint,lint)->(lint)',op_bxor_offset,0,line,0) + call dcl_proc(parser,'shift(lint,lint)->(lint)',& op_bshift_offset,0,line,0) - call dcl_proc(parser,'pdiff(lint,lint)->lint',op_pdiff_offset,0,line,0) - call dcl_proc(parser,'sign(lint,lint)->lint',op_sign_offset,0,line,0) - call dcl_proc(parser,'rem(lint,lint)->lint',op_modulo_offset,0,line,0) - call dcl_proc(parser,'int8(lint)->int8',op_i8_offset,0,line,0) - call dcl_proc(parser,'int16(lint)->int16',op_i16_offset,0,line,0) - call dcl_proc(parser,'int32(lint)->int32',op_i32_offset,0,line,0) - call dcl_proc(parser,'int64(lint)->int64',op_i64_offset,0,line,0) - call dcl_proc(parser,'int(lint)->int',op_long_offset,0,line,0) + call dcl_proc(parser,'pdiff(lint,lint)->(lint)',op_pdiff_offset,0,line,0) + call dcl_proc(parser,'sign(lint,lint)->(lint)',op_sign_offset,0,line,0) + call dcl_proc(parser,'rem(lint,lint)->(lint)',op_modulo_offset,0,line,0) + call dcl_proc(parser,'int8(lint)->(int8)',op_i8_offset,0,line,0) + call dcl_proc(parser,'int16(lint)->(int16)',op_i16_offset,0,line,0) + call dcl_proc(parser,'int32(lint)->(int32)',op_i32_offset,0,line,0) + call dcl_proc(parser,'int64(lint)->(int64)',op_i64_offset,0,line,0) + call dcl_proc(parser,'int(lint)->(int)',op_long_offset,0,line,0) ! int8 type call dcl_proc(parser,'PM__assign_var(&int8,int8)',& op_assign_i8,0,line,0) - call dcl_proc(parser,'mod(int8,int8)->int8',op_mod_i8,0,line,0) - call dcl_proc(parser,'==(int8,int8)->bool',op_eq_i8,0,line,0) - call dcl_proc(parser,'/=(int8,int8)->bool',op_ne_i8,0,line,0) - call dcl_proc(parser,'>=(int8,int8)->bool',op_ge_i8,0,line,0) - call dcl_proc(parser,'>(int8,int8)->bool',op_gt_i8,0,line,0) - call dcl_proc(parser,'+(int8,int8)->int8',op_add_i8,0,line,0) + call dcl_proc(parser,'mod(int8,int8)->(int8)',op_mod_i8,0,line,0) + call dcl_proc(parser,'==(int8,int8)->(bool)',op_eq_i8,0,line,0) + call dcl_proc(parser,'/=(int8,int8)->(bool)',op_ne_i8,0,line,0) + call dcl_proc(parser,'>=(int8,int8)->(bool)',op_ge_i8,0,line,0) + call dcl_proc(parser,'>(int8,int8)->(bool)',op_gt_i8,0,line,0) + call dcl_proc(parser,'+(int8,int8)->(int8)',op_add_i8,0,line,0) call dcl_uproc(parser,'+(x:int8,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int8)=y',line) - call dcl_proc(parser,'-(int8,int8)->int8',op_sub_i8,0,line,0) + call dcl_proc(parser,'-(int8,int8)->(int8)',op_sub_i8,0,line,0) call dcl_uproc(parser,'-(x:int8,y:''0)=x',line) - call dcl_proc(parser,'*(int8,int8)->int8',op_mult_i8,0,line,0) + call dcl_proc(parser,'*(int8,int8)->(int8)',op_mult_i8,0,line,0) call dcl_uproc(parser,'*(x:int8,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int8)=y',line) - call dcl_proc(parser,'/(int8,int8)->int8',op_divide_i8,0,line,0) + call dcl_proc(parser,'/(int8,int8)->(int8)',op_divide_i8,0,line,0) call dcl_uproc(parser,'/(x:int8,y:''1)=x',line) - call dcl_proc(parser,'**(int8,int8)->int8',op_pow_i8,0,line,0) + call dcl_proc(parser,'**(int8,int8)->(int8)',op_pow_i8,0,line,0) call dcl_uproc(parser,'**(x:int8,y:''0)=1',line) call dcl_uproc(parser,'**(x:int8,y:''1)=x',line) call dcl_uproc(parser,'**(x:int8,y:''2)=x*x',line) - call dcl_proc(parser,'max(int8,int8)->int8',op_max_i8,0,line,0) - call dcl_proc(parser,'min(int8,int8)->int8',op_min_i8,0,line,0) - call dcl_proc(parser,'-(int8)->int8',op_uminus_i8,0,line,0) - call dcl_proc(parser,'sint(int8)->sint',op_int_i8,0,line,0) - call dcl_proc(parser,'sreal(int8)->sreal',op_real_i8,0,line,0) - call dcl_proc(parser,'real(int8)->real',op_double_i8,0,line,0) + call dcl_proc(parser,'max(int8,int8)->(int8)',op_max_i8,0,line,0) + call dcl_proc(parser,'min(int8,int8)->(int8)',op_min_i8,0,line,0) + call dcl_proc(parser,'-(int8)->(int8)',op_uminus_i8,0,line,0) + call dcl_proc(parser,'sint(int8)->(sint)',op_int_i8,0,line,0) + call dcl_proc(parser,'sreal(int8)->(sreal)',op_real_i8,0,line,0) + call dcl_proc(parser,'real(int8)->(real)',op_double_i8,0,line,0) call dcl_uproc(parser,'int8(x:int8)=x',line) - call dcl_proc(parser,'abs(int8)->int8',op_abs_i8,0,line,0) - call dcl_proc(parser,'~(int8)->int8',op_bnot_i8,0,line,0) - call dcl_proc(parser,'&(int8,int8)->int8',op_band_i8,0,line,0) - call dcl_proc(parser,'|(int8,int8)->int8',op_bor_i8,0,line,0) - call dcl_proc(parser,'xor(int8,int8)->int8',op_bxor_i8,0,line,0) - call dcl_proc(parser,'shift(int8,int8)->int8',& + call dcl_proc(parser,'abs(int8)->(int8)',op_abs_i8,0,line,0) + call dcl_proc(parser,'~(int8)->(int8)',op_bnot_i8,0,line,0) + call dcl_proc(parser,'&(int8,int8)->(int8)',op_band_i8,0,line,0) + call dcl_proc(parser,'|(int8,int8)->(int8)',op_bor_i8,0,line,0) + call dcl_proc(parser,'xor(int8,int8)->(int8)',op_bxor_i8,0,line,0) + call dcl_proc(parser,'shift(int8,int8)->(int8)',& op_bshift_i8,0,line,0) - call dcl_proc(parser,'pdiff(int8,int8)->int8',op_pdiff_i8,0,line,0) - call dcl_proc(parser,'sign(int8,int8)->int8',op_sign_i8,0,line,0) - call dcl_proc(parser,'rem(int8,int8)->int8',op_modulo_i8,0,line,0) - call dcl_proc(parser,'int16(int8)->int16',op_i16_i8,0,line,0) - call dcl_proc(parser,'int32(int8)->int32',op_i32_i8,0,line,0) - call dcl_proc(parser,'int64(int8)->int64',op_i64_i8,0,line,0) - call dcl_proc(parser,'int(int8)->int',op_long_i8,0,line,0) - call dcl_proc(parser,'lint(int8)->lint',op_offset_i8,0,line,0) + call dcl_proc(parser,'pdiff(int8,int8)->(int8)',op_pdiff_i8,0,line,0) + call dcl_proc(parser,'sign(int8,int8)->(int8)',op_sign_i8,0,line,0) + call dcl_proc(parser,'rem(int8,int8)->(int8)',op_modulo_i8,0,line,0) + call dcl_proc(parser,'int16(int8)->(int16)',op_i16_i8,0,line,0) + call dcl_proc(parser,'int32(int8)->(int32)',op_i32_i8,0,line,0) + call dcl_proc(parser,'int64(int8)->(int64)',op_i64_i8,0,line,0) + call dcl_proc(parser,'int(int8)->(int)',op_long_i8,0,line,0) + call dcl_proc(parser,'lint(int8)->(lint)',op_offset_i8,0,line,0) ! int16 type call dcl_proc(parser,'PM__assign_var(&int16,int16)',& op_assign_i16,0,line,0) - call dcl_proc(parser,'mod(int16,int16)->int16',op_mod_i16,0,line,0) - call dcl_proc(parser,'==(int16,int16)->bool',op_eq_i16,0,line,0) - call dcl_proc(parser,'/=(int16,int16)->bool',op_ne_i16,0,line,0) - call dcl_proc(parser,'>=(int16,int16)->bool',op_ge_i16,0,line,0) - call dcl_proc(parser,'>(int16,int16)->bool',op_gt_i16,0,line,0) - call dcl_proc(parser,'+(int16,int16)->int16',op_add_i16,0,line,0) + call dcl_proc(parser,'mod(int16,int16)->(int16)',op_mod_i16,0,line,0) + call dcl_proc(parser,'==(int16,int16)->(bool)',op_eq_i16,0,line,0) + call dcl_proc(parser,'/=(int16,int16)->(bool)',op_ne_i16,0,line,0) + call dcl_proc(parser,'>=(int16,int16)->(bool)',op_ge_i16,0,line,0) + call dcl_proc(parser,'>(int16,int16)->(bool)',op_gt_i16,0,line,0) + call dcl_proc(parser,'+(int16,int16)->(int16)',op_add_i16,0,line,0) call dcl_uproc(parser,'+(x:int16,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int16)=y',line) - call dcl_proc(parser,'-(int16,int16)->int16',op_sub_i16,0,line,0) + call dcl_proc(parser,'-(int16,int16)->(int16)',op_sub_i16,0,line,0) call dcl_uproc(parser,'-(x:int16,y:''0)=x',line) - call dcl_proc(parser,'*(int16,int16)->int16',op_mult_i16,0,line,0) + call dcl_proc(parser,'*(int16,int16)->(int16)',op_mult_i16,0,line,0) call dcl_uproc(parser,'*(x:int16,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int16)=y',line) - call dcl_proc(parser,'/(int16,int16)->int16',op_divide_i16,0,line,0) + call dcl_proc(parser,'/(int16,int16)->(int16)',op_divide_i16,0,line,0) call dcl_uproc(parser,'/(x:int16,y:''1)=x',line) - call dcl_proc(parser,'**(int16,int16)->int16',op_pow_i16,0,line,0) + call dcl_proc(parser,'**(int16,int16)->(int16)',op_pow_i16,0,line,0) call dcl_uproc(parser,'**(x:int16,y:''0)=1',line) call dcl_uproc(parser,'**(x:int16,y:''1)=x',line) call dcl_uproc(parser,'**(x:int16,y:''2)=x*x',line) - call dcl_proc(parser,'max(int16,int16)->int16',op_max_i16,0,line,0) - call dcl_proc(parser,'min(int16,int16)->int16',op_min_i16,0,line,0) - call dcl_proc(parser,'-(int16)->int16',op_uminus_i16,0,line,0) - call dcl_proc(parser,'sint(int16)->sint',op_int_i16,0,line,0) - call dcl_proc(parser,'sreal(int16)->sreal',op_real_i16,0,line,0) - call dcl_proc(parser,'real(int16)->real',op_double_i16,0,line,0) + call dcl_proc(parser,'max(int16,int16)->(int16)',op_max_i16,0,line,0) + call dcl_proc(parser,'min(int16,int16)->(int16)',op_min_i16,0,line,0) + call dcl_proc(parser,'-(int16)->(int16)',op_uminus_i16,0,line,0) + call dcl_proc(parser,'sint(int16)->(sint)',op_int_i16,0,line,0) + call dcl_proc(parser,'sreal(int16)->(sreal)',op_real_i16,0,line,0) + call dcl_proc(parser,'real(int16)->(real)',op_double_i16,0,line,0) call dcl_uproc(parser,'int16(x:int16)=x',line) - call dcl_proc(parser,'abs(int16)->int16',op_abs_i16,0,line,0) - call dcl_proc(parser,'~(int16)->int16',op_bnot_i16,0,line,0) - call dcl_proc(parser,'&(int16,int16)->int16',op_band_i16,0,line,0) - call dcl_proc(parser,'|(int16,int16)->int16',op_bor_i16,0,line,0) - call dcl_proc(parser,'xor(int16,int16)->int16',op_bxor_i16,0,line,0) - call dcl_proc(parser,'shift(int16,int16)->int16',& + call dcl_proc(parser,'abs(int16)->(int16)',op_abs_i16,0,line,0) + call dcl_proc(parser,'~(int16)->(int16)',op_bnot_i16,0,line,0) + call dcl_proc(parser,'&(int16,int16)->(int16)',op_band_i16,0,line,0) + call dcl_proc(parser,'|(int16,int16)->(int16)',op_bor_i16,0,line,0) + call dcl_proc(parser,'xor(int16,int16)->(int16)',op_bxor_i16,0,line,0) + call dcl_proc(parser,'shift(int16,int16)->(int16)',& op_bshift_i16,0,line,0) - call dcl_proc(parser,'pdiff(int16,int16)->int16',op_pdiff_i16,0,line,0) - call dcl_proc(parser,'sign(int16,int16)->int16',op_sign_i16,0,line,0) - call dcl_proc(parser,'rem(int16,int16)->int16',op_modulo_i16,0,line,0) - call dcl_proc(parser,'int8(int16)->int16',op_i8_i16,0,line,0) - call dcl_proc(parser,'int32(int16)->int32',op_i32_i16,0,line,0) - call dcl_proc(parser,'int64(int16)->int64',op_i64_i16,0,line,0) - call dcl_proc(parser,'int(int16)->int',op_long_i16,0,line,0) - call dcl_proc(parser,'lint(int16)->lint',op_offset_i16,0,line,0) + call dcl_proc(parser,'pdiff(int16,int16)->(int16)',op_pdiff_i16,0,line,0) + call dcl_proc(parser,'sign(int16,int16)->(int16)',op_sign_i16,0,line,0) + call dcl_proc(parser,'rem(int16,int16)->(int16)',op_modulo_i16,0,line,0) + call dcl_proc(parser,'int8(int16)->(int16)',op_i8_i16,0,line,0) + call dcl_proc(parser,'int32(int16)->(int32)',op_i32_i16,0,line,0) + call dcl_proc(parser,'int64(int16)->(int64)',op_i64_i16,0,line,0) + call dcl_proc(parser,'int(int16)->(int)',op_long_i16,0,line,0) + call dcl_proc(parser,'lint(int16)->(lint)',op_offset_i16,0,line,0) ! int32 type call dcl_proc(parser,'PM__assign_var(&int32,int32)',& op_assign_i32,0,line,0) - call dcl_proc(parser,'mod(int32,int32)->int32',op_mod_i32,0,line,0) - call dcl_proc(parser,'==(int32,int32)->bool',op_eq_i32,0,line,0) - call dcl_proc(parser,'/=(int32,int32)->bool',op_ne_i32,0,line,0) - call dcl_proc(parser,'>=(int32,int32)->bool',op_ge_i32,0,line,0) - call dcl_proc(parser,'>(int32,int32)->bool',op_gt_i32,0,line,0) - call dcl_proc(parser,'+(int32,int32)->int32',op_add_i32,0,line,0) + call dcl_proc(parser,'mod(int32,int32)->(int32)',op_mod_i32,0,line,0) + call dcl_proc(parser,'==(int32,int32)->(bool)',op_eq_i32,0,line,0) + call dcl_proc(parser,'/=(int32,int32)->(bool)',op_ne_i32,0,line,0) + call dcl_proc(parser,'>=(int32,int32)->(bool)',op_ge_i32,0,line,0) + call dcl_proc(parser,'>(int32,int32)->(bool)',op_gt_i32,0,line,0) + call dcl_proc(parser,'+(int32,int32)->(int32)',op_add_i32,0,line,0) call dcl_uproc(parser,'+(x:int32,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int32)=y',line) - call dcl_proc(parser,'-(int32,int32)->int32',op_sub_i32,0,line,0) + call dcl_proc(parser,'-(int32,int32)->(int32)',op_sub_i32,0,line,0) call dcl_uproc(parser,'-(x:int32,y:''0)=x',line) - call dcl_proc(parser,'*(int32,int32)->int32',op_mult_i32,0,line,0) + call dcl_proc(parser,'*(int32,int32)->(int32)',op_mult_i32,0,line,0) call dcl_uproc(parser,'*(x:int32,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int32)=y',line) - call dcl_proc(parser,'/(int32,int32)->int32',op_divide_i32,0,line,0) + call dcl_proc(parser,'/(int32,int32)->(int32)',op_divide_i32,0,line,0) call dcl_uproc(parser,'/(x:int32,y:''1)=x',line) - call dcl_proc(parser,'**(int32,int32)->int32',op_pow_i32,0,line,0) + call dcl_proc(parser,'**(int32,int32)->(int32)',op_pow_i32,0,line,0) call dcl_uproc(parser,'**(x:int32,y:''0)=1',line) call dcl_uproc(parser,'**(x:int32,y:''1)=x',line) call dcl_uproc(parser,'**(x:int32,y:''2)=x*x',line) - call dcl_proc(parser,'max(int32,int32)->int32',op_max_i32,0,line,0) - call dcl_proc(parser,'min(int32,int32)->int32',op_min_i32,0,line,0) - call dcl_proc(parser,'-(int32)->int32',op_uminus_i32,0,line,0) - call dcl_proc(parser,'sint(int32)->sint',op_int_i32,0,line,0) - call dcl_proc(parser,'sreal(int32)->sreal',op_real_i32,0,line,0) - call dcl_proc(parser,'real(int32)->real',op_double_i32,0,line,0) + call dcl_proc(parser,'max(int32,int32)->(int32)',op_max_i32,0,line,0) + call dcl_proc(parser,'min(int32,int32)->(int32)',op_min_i32,0,line,0) + call dcl_proc(parser,'-(int32)->(int32)',op_uminus_i32,0,line,0) + call dcl_proc(parser,'sint(int32)->(sint)',op_int_i32,0,line,0) + call dcl_proc(parser,'sreal(int32)->(sreal)',op_real_i32,0,line,0) + call dcl_proc(parser,'real(int32)->(real)',op_double_i32,0,line,0) call dcl_uproc(parser,'int32(x:int32)=x',line) - call dcl_proc(parser,'abs(int32)->int32',op_abs_i32,0,line,0) - call dcl_proc(parser,'~(int32)->int32',op_bnot_i32,0,line,0) - call dcl_proc(parser,'&(int32,int32)->int32',op_band_i32,0,line,0) - call dcl_proc(parser,'|(int32,int32)->int32',op_bor_i32,0,line,0) - call dcl_proc(parser,'xor(int32,int32)->int32',op_bxor_i32,0,line,0) - call dcl_proc(parser,'shift(int32,int32)->int32',& + call dcl_proc(parser,'abs(int32)->(int32)',op_abs_i32,0,line,0) + call dcl_proc(parser,'~(int32)->(int32)',op_bnot_i32,0,line,0) + call dcl_proc(parser,'&(int32,int32)->(int32)',op_band_i32,0,line,0) + call dcl_proc(parser,'|(int32,int32)->(int32)',op_bor_i32,0,line,0) + call dcl_proc(parser,'xor(int32,int32)->(int32)',op_bxor_i32,0,line,0) + call dcl_proc(parser,'shift(int32,int32)->(int32)',& op_bshift_i32,0,line,0) - call dcl_proc(parser,'pdiff(int32,int32)->int32',op_pdiff_i32,0,line,0) - call dcl_proc(parser,'sign(int32,int32)->int32',op_sign_i32,0,line,0) - call dcl_proc(parser,'rem(int32,int32)->int32',op_modulo_i32,0,line,0) - call dcl_proc(parser,'int8(int32)->int32',op_i8_i32,0,line,0) - call dcl_proc(parser,'int16(int32)->int32',op_i16_i32,0,line,0) - call dcl_proc(parser,'int64(int32)->int64',op_i64_i32,0,line,0) - call dcl_proc(parser,'int(int32)->int',op_long_i32,0,line,0) - call dcl_proc(parser,'lint(int32)->lint',op_offset_i32,0,line,0) + call dcl_proc(parser,'pdiff(int32,int32)->(int32)',op_pdiff_i32,0,line,0) + call dcl_proc(parser,'sign(int32,int32)->(int32)',op_sign_i32,0,line,0) + call dcl_proc(parser,'rem(int32,int32)->(int32)',op_modulo_i32,0,line,0) + call dcl_proc(parser,'int8(int32)->(int32)',op_i8_i32,0,line,0) + call dcl_proc(parser,'int16(int32)->(int32)',op_i16_i32,0,line,0) + call dcl_proc(parser,'int64(int32)->(int64)',op_i64_i32,0,line,0) + call dcl_proc(parser,'int(int32)->(int)',op_long_i32,0,line,0) + call dcl_proc(parser,'lint(int32)->(lint)',op_offset_i32,0,line,0) ! int64 type call dcl_proc(parser,'PM__assign_var(&int64,int64)',& op_assign_i64,0,line,0) - call dcl_proc(parser,'mod(int64,int64)->int64',op_mod_i64,0,line,0) - call dcl_proc(parser,'==(int64,int64)->bool',op_eq_i64,0,line,0) - call dcl_proc(parser,'/=(int64,int64)->bool',op_ne_i64,0,line,0) - call dcl_proc(parser,'>=(int64,int64)->bool',op_ge_i64,0,line,0) - call dcl_proc(parser,'>(int64,int64)->bool',op_gt_i64,0,line,0) - call dcl_proc(parser,'+(int64,int64)->int64',op_add_i64,0,line,0) + call dcl_proc(parser,'mod(int64,int64)->(int64)',op_mod_i64,0,line,0) + call dcl_proc(parser,'==(int64,int64)->(bool)',op_eq_i64,0,line,0) + call dcl_proc(parser,'/=(int64,int64)->(bool)',op_ne_i64,0,line,0) + call dcl_proc(parser,'>=(int64,int64)->(bool)',op_ge_i64,0,line,0) + call dcl_proc(parser,'>(int64,int64)->(bool)',op_gt_i64,0,line,0) + call dcl_proc(parser,'+(int64,int64)->(int64)',op_add_i64,0,line,0) call dcl_uproc(parser,'+(x:int64,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int64)=y',line) - call dcl_proc(parser,'-(int64,int64)->int64',op_sub_i64,0,line,0) + call dcl_proc(parser,'-(int64,int64)->(int64)',op_sub_i64,0,line,0) call dcl_uproc(parser,'-(x:int64,y:''0)=x',line) - call dcl_proc(parser,'*(int64,int64)->int64',op_mult_i64,0,line,0) + call dcl_proc(parser,'*(int64,int64)->(int64)',op_mult_i64,0,line,0) call dcl_uproc(parser,'*(x:int64,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int64)=y',line) - call dcl_proc(parser,'/(int64,int64)->int64',op_divide_i64,0,line,0) + call dcl_proc(parser,'/(int64,int64)->(int64)',op_divide_i64,0,line,0) call dcl_uproc(parser,'/(x:int64,y:''1)=x',line) - call dcl_proc(parser,'**(int64,int64)->int64',op_pow_i64,0,line,0) + call dcl_proc(parser,'**(int64,int64)->(int64)',op_pow_i64,0,line,0) call dcl_uproc(parser,'**(x:int64,y:''0)=1',line) call dcl_uproc(parser,'**(x:int64,y:''1)=x',line) call dcl_uproc(parser,'**(x:int64,y:''2)=x*x',line) - call dcl_proc(parser,'max(int64,int64)->int64',op_max_i64,0,line,0) - call dcl_proc(parser,'min(int64,int64)->int64',op_min_i64,0,line,0) - call dcl_proc(parser,'-(int64)->int64',op_uminus_i64,0,line,0) - call dcl_proc(parser,'string(int64)->string',op_string_i64,0,line,0) - call dcl_proc(parser,'sint(int64)->sint',op_int_i64,0,line,0) - call dcl_proc(parser,'sreal(int64)->sreal',op_real_i64,0,line,0) - call dcl_proc(parser,'real(int64)->real',op_double_i64,0,line,0) + call dcl_proc(parser,'max(int64,int64)->(int64)',op_max_i64,0,line,0) + call dcl_proc(parser,'min(int64,int64)->(int64)',op_min_i64,0,line,0) + call dcl_proc(parser,'-(int64)->(int64)',op_uminus_i64,0,line,0) + call dcl_proc(parser,'string(int64)->(string)',op_string_i64,0,line,0) + call dcl_proc(parser,'sint(int64)->(sint)',op_int_i64,0,line,0) + call dcl_proc(parser,'sreal(int64)->(sreal)',op_real_i64,0,line,0) + call dcl_proc(parser,'real(int64)->(real)',op_double_i64,0,line,0) call dcl_uproc(parser,'int64(x:int64)=x',line) - call dcl_proc(parser,'abs(int64)->int64',op_abs_i64,0,line,0) - call dcl_proc(parser,'~(int64)->int64',op_bnot_i64,0,line,0) - call dcl_proc(parser,'&(int64,int64)->int64',op_band_i64,0,line,0) - call dcl_proc(parser,'|(int64,int64)->int64',op_bor_i64,0,line,0) - call dcl_proc(parser,'xor(int64,int64)->int64',op_bxor_i64,0,line,0) - call dcl_proc(parser,'shift(int64,int64)->int64',& + call dcl_proc(parser,'abs(int64)->(int64)',op_abs_i64,0,line,0) + call dcl_proc(parser,'~(int64)->(int64)',op_bnot_i64,0,line,0) + call dcl_proc(parser,'&(int64,int64)->(int64)',op_band_i64,0,line,0) + call dcl_proc(parser,'|(int64,int64)->(int64)',op_bor_i64,0,line,0) + call dcl_proc(parser,'xor(int64,int64)->(int64)',op_bxor_i64,0,line,0) + call dcl_proc(parser,'shift(int64,int64)->(int64)',& op_bshift_i64,0,line,0) - call dcl_proc(parser,'pdiff(int64,int64)->int64',op_pdiff_i64,0,line,0) - call dcl_proc(parser,'sign(int64,int64)->int64',op_sign_i64,0,line,0) - call dcl_proc(parser,'rem(int64,int64)->int64',op_modulo_i64,0,line,0) - call dcl_proc(parser,'int8(int64)->int64',op_i8_i64,0,line,0) - call dcl_proc(parser,'int16(int64)->int64',op_i16_i64,0,line,0) - call dcl_proc(parser,'int32(int64)->int64',op_i32_i64,0,line,0) - call dcl_proc(parser,'int(int64)->int',op_long_i64,0,line,0) - call dcl_proc(parser,'lint(int64)->lint',op_offset_i64,0,line,0) + call dcl_proc(parser,'pdiff(int64,int64)->(int64)',op_pdiff_i64,0,line,0) + call dcl_proc(parser,'sign(int64,int64)->(int64)',op_sign_i64,0,line,0) + call dcl_proc(parser,'rem(int64,int64)->(int64)',op_modulo_i64,0,line,0) + call dcl_proc(parser,'int8(int64)->(int64)',op_i8_i64,0,line,0) + call dcl_proc(parser,'int16(int64)->(int64)',op_i16_i64,0,line,0) + call dcl_proc(parser,'int32(int64)->(int64)',op_i32_i64,0,line,0) + call dcl_proc(parser,'int(int64)->(int)',op_long_i64,0,line,0) + call dcl_proc(parser,'lint(int64)->(lint)',op_offset_i64,0,line,0) ! sreal type call dcl_proc(parser,'PM__assign_var(&sreal,sreal)',& op_assign_r,0,line,0) - call dcl_proc(parser,'mod(sreal,sreal)->sreal',op_mod_r,0,line,0) - call dcl_proc(parser,'==(sreal,sreal)->bool',op_eq_r,0,line,0) - call dcl_proc(parser,'/=(sreal,sreal)->bool',op_ne_r,0,line,0) - call dcl_proc(parser,'>=(sreal,sreal)->bool',op_ge_r,0,line,0) - call dcl_proc(parser,'>(sreal,sreal)->bool',op_gt_r,0,line,0) - call dcl_proc(parser,'+(sreal,sreal)->sreal',op_add_r,0,line,0) - call dcl_proc(parser,'-(sreal,sreal)->sreal',op_sub_r,0,line,0) - call dcl_proc(parser,'*(sreal,sreal)->sreal',op_mult_r,0,line,0) - call dcl_proc(parser,'/(sreal,sreal)->sreal',op_divide_r,0,line,0) - call dcl_proc(parser,'**(sreal,sreal)->sreal',op_pow_r,0,line,0) - call dcl_proc(parser,'max(sreal,sreal)->sreal',op_max_r,0,line,0) - call dcl_proc(parser,'min(sreal,sreal)->sreal',op_min_r,0,line,0) - call dcl_proc(parser,'-(sreal)->sreal',op_uminus_r,0,line,0) - call dcl_proc(parser,'string(sreal)->string',op_string_r,0,line,0) - call dcl_proc(parser,'strunc(sreal)->sint',op_int_r,0,line,0) - call dcl_proc(parser,'trunc(sreal)->int',op_long_r,0,line,0) - call dcl_proc(parser,'ltrunc(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'real(sreal)->real',op_double_r,0,line,0) + call dcl_proc(parser,'mod(sreal,sreal)->(sreal)',op_mod_r,0,line,0) + call dcl_proc(parser,'==(sreal,sreal)->(bool)',op_eq_r,0,line,0) + call dcl_proc(parser,'/=(sreal,sreal)->(bool)',op_ne_r,0,line,0) + call dcl_proc(parser,'>=(sreal,sreal)->(bool)',op_ge_r,0,line,0) + call dcl_proc(parser,'>(sreal,sreal)->(bool)',op_gt_r,0,line,0) + call dcl_proc(parser,'+(sreal,sreal)->(sreal)',op_add_r,0,line,0) + call dcl_proc(parser,'-(sreal,sreal)->(sreal)',op_sub_r,0,line,0) + call dcl_proc(parser,'*(sreal,sreal)->(sreal)',op_mult_r,0,line,0) + call dcl_proc(parser,'/(sreal,sreal)->(sreal)',op_divide_r,0,line,0) + call dcl_proc(parser,'**(sreal,sreal)->(sreal)',op_pow_r,0,line,0) + call dcl_proc(parser,'max(sreal,sreal)->(sreal)',op_max_r,0,line,0) + call dcl_proc(parser,'min(sreal,sreal)->(sreal)',op_min_r,0,line,0) + call dcl_proc(parser,'-(sreal)->(sreal)',op_uminus_r,0,line,0) + call dcl_proc(parser,'string(sreal)->(string)',op_string_r,0,line,0) + call dcl_proc(parser,'strunc(sreal)->(sint)',op_int_r,0,line,0) + call dcl_proc(parser,'trunc(sreal)->(int)',op_long_r,0,line,0) + call dcl_proc(parser,'ltrunc(sreal)->(lint)',op_offset_r,0,line,0) + call dcl_proc(parser,'real(sreal)->(real)',op_double_r,0,line,0) call dcl_uproc(parser,'sreal(x:sreal)=x',line) - call dcl_proc(parser,'abs(sreal)->sreal',op_abs_r,0,line,0) - call dcl_proc(parser,'acos(sreal)->sreal',op_acos_r,0,line,0) - call dcl_proc(parser,'asin(sreal)->sreal',op_asin_r,0,line,0) - call dcl_proc(parser,'atan(sreal)->sreal',op_atan_r,0,line,0) - call dcl_proc(parser,'atan2(sreal,sreal)->sreal',op_atan2_r,0,line,0) - call dcl_proc(parser,'cos(sreal)->sreal',op_cos_r,0,line,0) - call dcl_proc(parser,'cosh(sreal)->sreal',op_cosh_r,0,line,0) - call dcl_proc(parser,'exp(sreal)->sreal',op_exp_r,0,line,0) - call dcl_proc(parser,'log(sreal)->sreal',op_log_r,0,line,0) - call dcl_proc(parser,'log10(sreal)->sreal',op_log10_r,0,line,0) - call dcl_proc(parser,'sin(sreal)->sreal',op_sin_r,0,line,0) - call dcl_proc(parser,'sinh(sreal)->sreal',op_sinh_r,0,line,0) - call dcl_proc(parser,'sqrt(sreal)->sreal',op_sqrt_r,0,line,0) - call dcl_proc(parser,'tan(sreal)->sreal',op_tan_r,0,line,0) - call dcl_proc(parser,'tanh(sreal)->sreal',op_tanh_r,0,line,0) - call dcl_proc(parser,'floor(sreal)->sreal',op_floor_r,0,line,0) - call dcl_proc(parser,'ceil(sreal)->sreal',op_ceil_r,0,line,0) - call dcl_proc(parser,'rem(sreal,sreal)->sreal',op_modulo_r,0,line,0) - call dcl_proc(parser,'sign(sreal,sreal)->sreal',op_sign_r,0,line,0) - call dcl_proc(parser,'pdiff(sreal,sreal)->sreal',op_pdiff_r,0,line,0) - call dcl_proc(parser,'lint(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'scpx(sreal)->scpx',op_complex_r,0,line,0) - call dcl_proc(parser,'_scpx2(sreal,sreal)->scpx',op_complex2_r,0,line,0) + call dcl_proc(parser,'abs(sreal)->(sreal)',op_abs_r,0,line,0) + call dcl_proc(parser,'acos(sreal)->(sreal)',op_acos_r,0,line,0) + call dcl_proc(parser,'asin(sreal)->(sreal)',op_asin_r,0,line,0) + call dcl_proc(parser,'atan(sreal)->(sreal)',op_atan_r,0,line,0) + call dcl_proc(parser,'atan2(sreal,sreal)->(sreal)',op_atan2_r,0,line,0) + call dcl_proc(parser,'cos(sreal)->(sreal)',op_cos_r,0,line,0) + call dcl_proc(parser,'cosh(sreal)->(sreal)',op_cosh_r,0,line,0) + call dcl_proc(parser,'exp(sreal)->(sreal)',op_exp_r,0,line,0) + call dcl_proc(parser,'log(sreal)->(sreal)',op_log_r,0,line,0) + call dcl_proc(parser,'log10(sreal)->(sreal)',op_log10_r,0,line,0) + call dcl_proc(parser,'sin(sreal)->(sreal)',op_sin_r,0,line,0) + call dcl_proc(parser,'sinh(sreal)->(sreal)',op_sinh_r,0,line,0) + call dcl_proc(parser,'sqrt(sreal)->(sreal)',op_sqrt_r,0,line,0) + call dcl_proc(parser,'tan(sreal)->(sreal)',op_tan_r,0,line,0) + call dcl_proc(parser,'tanh(sreal)->(sreal)',op_tanh_r,0,line,0) + call dcl_proc(parser,'floor(sreal)->(sreal)',op_floor_r,0,line,0) + call dcl_proc(parser,'ceil(sreal)->(sreal)',op_ceil_r,0,line,0) + call dcl_proc(parser,'rem(sreal,sreal)->(sreal)',op_modulo_r,0,line,0) + call dcl_proc(parser,'sign(sreal,sreal)->(sreal)',op_sign_r,0,line,0) + call dcl_proc(parser,'pdiff(sreal,sreal)->(sreal)',op_pdiff_r,0,line,0) + call dcl_proc(parser,'lint(sreal)->(lint)',op_offset_r,0,line,0) + call dcl_proc(parser,'scpx(sreal)->(scpx)',op_complex_r,0,line,0) + call dcl_proc(parser,'_scpx2(sreal,sreal)->(scpx)',op_complex2_r,0,line,0) call dcl_uproc(parser,'scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y))',line) ! real type call dcl_proc(parser,'PM__assign_var(&real,real)',& op_assign_d,0,line,0) - call dcl_proc(parser,'mod(real,real)->real',op_mod_d,0,line,0) - call dcl_proc(parser,'==(real,real)->bool',op_eq_d,0,line,0) - call dcl_proc(parser,'/=(real,real)->bool',op_ne_d,0,line,0) - call dcl_proc(parser,'>=(real,real)->bool',op_ge_d,0,line,0) - call dcl_proc(parser,'>(real,real)->bool',op_gt_d,0,line,0) - call dcl_proc(parser,'+(real,real)->real',op_add_d,0,line,0) - call dcl_proc(parser,'-(real,real)->real',op_sub_d,0,line,0) - call dcl_proc(parser,'*(real,real)->real',op_mult_d,0,line,0) - call dcl_proc(parser,'/(real,real)->real',op_divide_d,0,line,0) - call dcl_proc(parser,'**(real,real)->real',op_pow_d,0,line,0) - call dcl_proc(parser,'max(real,real)->real',op_max_d,0,line,0) - call dcl_proc(parser,'min(real,real)->real',op_min_d,0,line,0) - call dcl_proc(parser,'-(real)->real',op_uminus_d,0,line,0) - call dcl_proc(parser,'string(real)->string',op_string_d,0,line,0) - call dcl_proc(parser,'strunc(real)->sint',op_int_d,0,line,0) - call dcl_proc(parser,'trunc(real)->int',op_long_d,0,line,0) - call dcl_proc(parser,'ltrunc(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'sreal(real)->sreal',op_real_d,0,line,0) + call dcl_proc(parser,'mod(real,real)->(real)',op_mod_d,0,line,0) + call dcl_proc(parser,'==(real,real)->(bool)',op_eq_d,0,line,0) + call dcl_proc(parser,'/=(real,real)->(bool)',op_ne_d,0,line,0) + call dcl_proc(parser,'>=(real,real)->(bool)',op_ge_d,0,line,0) + call dcl_proc(parser,'>(real,real)->(bool)',op_gt_d,0,line,0) + call dcl_proc(parser,'+(real,real)->(real)',op_add_d,0,line,0) + call dcl_proc(parser,'-(real,real)->(real)',op_sub_d,0,line,0) + call dcl_proc(parser,'*(real,real)->(real)',op_mult_d,0,line,0) + call dcl_proc(parser,'/(real,real)->(real)',op_divide_d,0,line,0) + call dcl_proc(parser,'**(real,real)->(real)',op_pow_d,0,line,0) + call dcl_proc(parser,'max(real,real)->(real)',op_max_d,0,line,0) + call dcl_proc(parser,'min(real,real)->(real)',op_min_d,0,line,0) + call dcl_proc(parser,'-(real)->(real)',op_uminus_d,0,line,0) + call dcl_proc(parser,'string(real)->(string)',op_string_d,0,line,0) + call dcl_proc(parser,'strunc(real)->(sint)',op_int_d,0,line,0) + call dcl_proc(parser,'trunc(real)->(int)',op_long_d,0,line,0) + call dcl_proc(parser,'ltrunc(real)->(lint)',op_offset_d,0,line,0) + call dcl_proc(parser,'sreal(real)->(sreal)',op_real_d,0,line,0) call dcl_uproc(parser,'real(x:real)=x',line) - call dcl_proc(parser,'abs(real)->real',op_abs_d,0,line,0) - call dcl_proc(parser,'acos(real)->real',op_acos_d,0,line,0) - call dcl_proc(parser,'asin(real)->real',op_asin_d,0,line,0) - call dcl_proc(parser,'atan(real)->real',op_atan_d,0,line,0) - call dcl_proc(parser,'atan2(real,real)->real',& + call dcl_proc(parser,'abs(real)->(real)',op_abs_d,0,line,0) + call dcl_proc(parser,'acos(real)->(real)',op_acos_d,0,line,0) + call dcl_proc(parser,'asin(real)->(real)',op_asin_d,0,line,0) + call dcl_proc(parser,'atan(real)->(real)',op_atan_d,0,line,0) + call dcl_proc(parser,'atan2(real,real)->(real)',& op_atan2_d,0,line,0) - call dcl_proc(parser,'cos(real)->real',op_cos_d,0,line,0) - call dcl_proc(parser,'cosh(real)->real',op_cosh_d,0,line,0) - call dcl_proc(parser,'exp(real)->real',op_exp_d,0,line,0) - call dcl_proc(parser,'log(real)->real',op_log_d,0,line,0) - call dcl_proc(parser,'log10(real)->real',op_log10_d,0,line,0) - call dcl_proc(parser,'sin(real)->real',op_sin_d,0,line,0) - call dcl_proc(parser,'sinh(real)->real',op_sinh_d,0,line,0) - call dcl_proc(parser,'sqrt(real)->real',op_sqrt_d,0,line,0) - call dcl_proc(parser,'tan(real)->real',op_tan_d,0,line,0) - call dcl_proc(parser,'tanh(real)->real',op_tanh_d,0,line,0) - call dcl_proc(parser,'floor(real)->real',op_floor_d,0,line,0) - call dcl_proc(parser,'ceil(real)->real',op_ceil_d,0,line,0) - call dcl_proc(parser,'rem(real,real)->real',op_modulo_d,0,line,0) - call dcl_proc(parser,'sign(real,real)->real',op_sign_d,0,line,0) - call dcl_proc(parser,'pdiff(real,real)->real',op_pdiff_d,0,line,0) - call dcl_proc(parser,'lint(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'cpx(real)->cpx',op_complex_d,0,line,0) - call dcl_proc(parser,'_cpx2(real,real)->cpx',op_complex2_d,0,line,0) + call dcl_proc(parser,'cos(real)->(real)',op_cos_d,0,line,0) + call dcl_proc(parser,'cosh(real)->(real)',op_cosh_d,0,line,0) + call dcl_proc(parser,'exp(real)->(real)',op_exp_d,0,line,0) + call dcl_proc(parser,'log(real)->(real)',op_log_d,0,line,0) + call dcl_proc(parser,'log10(real)->(real)',op_log10_d,0,line,0) + call dcl_proc(parser,'sin(real)->(real)',op_sin_d,0,line,0) + call dcl_proc(parser,'sinh(real)->(real)',op_sinh_d,0,line,0) + call dcl_proc(parser,'sqrt(real)->(real)',op_sqrt_d,0,line,0) + call dcl_proc(parser,'tan(real)->(real)',op_tan_d,0,line,0) + call dcl_proc(parser,'tanh(real)->(real)',op_tanh_d,0,line,0) + call dcl_proc(parser,'floor(real)->(real)',op_floor_d,0,line,0) + call dcl_proc(parser,'ceil(real)->(real)',op_ceil_d,0,line,0) + call dcl_proc(parser,'rem(real,real)->(real)',op_modulo_d,0,line,0) + call dcl_proc(parser,'sign(real,real)->(real)',op_sign_d,0,line,0) + call dcl_proc(parser,'pdiff(real,real)->(real)',op_pdiff_d,0,line,0) + call dcl_proc(parser,'lint(real)->(lint)',op_offset_d,0,line,0) + call dcl_proc(parser,'cpx(real)->(cpx)',op_complex_d,0,line,0) + call dcl_proc(parser,'_cpx2(real,real)->(cpx)',op_complex2_d,0,line,0) call dcl_uproc(parser,'cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y))',line) ! scpx type call dcl_proc(parser,'PM__assign_var(&scpx,scpx)',& op_assign_c,0,line,0) - call dcl_proc(parser,'+(scpx,scpx)->scpx',op_add_c,0,line,0) - call dcl_proc(parser,'-(scpx,scpx)->scpx',op_sub_c,0,line,0) - call dcl_proc(parser,'*(scpx,scpx)->scpx',op_mult_c,0,line,0) - call dcl_proc(parser,'/(scpx,scpx)->scpx',op_divide_c,0,line,0) - call dcl_proc(parser,'**(scpx,sreal)->scpx',op_rpow_c,0,line,0) - call dcl_proc(parser,'**(scpx,scpx)->scpx',op_pow_c,0,line,0) - call dcl_proc(parser,'-(scpx)->scpx',op_uminus_c,0,line,0) - call dcl_proc(parser,'==(scpx,scpx)->bool',op_eq_c,0,line,0) - call dcl_proc(parser,'/=(scpx,scpx)->bool',op_ne_c,0,line,0) - call dcl_proc(parser,'re(scpx)->sreal',op_real_c,0,line,0) - call dcl_proc(parser,'abs(scpx)->scpx',op_abs_c,0,line,0) - call dcl_proc(parser,'acos(scpx)->scpx',op_acos_c,0,line,0) - call dcl_proc(parser,'asin(scpx)->scpx',op_asin_c,0,line,0) - call dcl_proc(parser,'atan(scpx)->scpx',op_atan_c,0,line,0) - call dcl_proc(parser,'atan2(scpx,scpx)->scpx',& + call dcl_proc(parser,'+(scpx,scpx)->(scpx)',op_add_c,0,line,0) + call dcl_proc(parser,'-(scpx,scpx)->(scpx)',op_sub_c,0,line,0) + call dcl_proc(parser,'*(scpx,scpx)->(scpx)',op_mult_c,0,line,0) + call dcl_proc(parser,'/(scpx,scpx)->(scpx)',op_divide_c,0,line,0) + call dcl_proc(parser,'**(scpx,sreal)->(scpx)',op_rpow_c,0,line,0) + call dcl_proc(parser,'**(scpx,scpx)->(scpx)',op_pow_c,0,line,0) + call dcl_proc(parser,'-(scpx)->(scpx)',op_uminus_c,0,line,0) + call dcl_proc(parser,'==(scpx,scpx)->(bool)',op_eq_c,0,line,0) + call dcl_proc(parser,'/=(scpx,scpx)->(bool)',op_ne_c,0,line,0) + call dcl_proc(parser,'re(scpx)->(sreal)',op_real_c,0,line,0) + call dcl_proc(parser,'abs(scpx)->(scpx)',op_abs_c,0,line,0) + call dcl_proc(parser,'acos(scpx)->(scpx)',op_acos_c,0,line,0) + call dcl_proc(parser,'asin(scpx)->(scpx)',op_asin_c,0,line,0) + call dcl_proc(parser,'atan(scpx)->(scpx)',op_atan_c,0,line,0) + call dcl_proc(parser,'atan2(scpx,scpx)->(scpx)',& op_atan2_c,0,line,0) - call dcl_proc(parser,'cos(scpx)->scpx',op_cos_c,0,line,0) - call dcl_proc(parser,'cosh(scpx)->scpx',op_cosh_c,0,line,0) - call dcl_proc(parser,'exp(scpx)->scpx',op_exp_c,0,line,0) - call dcl_proc(parser,'log(scpx)->scpx',op_log_c,0,line,0) - call dcl_proc(parser,'sin(scpx)->scpx',op_sin_c,0,line,0) - call dcl_proc(parser,'sinh(scpx)->scpx',op_sinh_c,0,line,0) - call dcl_proc(parser,'sqrt(scpx)->scpx',op_sqrt_c,0,line,0) - call dcl_proc(parser,'tan(scpx)->scpx',op_tan_c,0,line,0) - call dcl_proc(parser,'tanh(scpx)->scpx',op_tanh_c,0,line,0) - call dcl_proc(parser,'im(scpx)->sreal',op_imag_c,0,line,0) - call dcl_proc(parser,'conj(scpx)->scpx',op_conj_c,0,line,0) + call dcl_proc(parser,'cos(scpx)->(scpx)',op_cos_c,0,line,0) + call dcl_proc(parser,'cosh(scpx)->(scpx)',op_cosh_c,0,line,0) + call dcl_proc(parser,'exp(scpx)->(scpx)',op_exp_c,0,line,0) + call dcl_proc(parser,'log(scpx)->(scpx)',op_log_c,0,line,0) + call dcl_proc(parser,'sin(scpx)->(scpx)',op_sin_c,0,line,0) + call dcl_proc(parser,'sinh(scpx)->(scpx)',op_sinh_c,0,line,0) + call dcl_proc(parser,'sqrt(scpx)->(scpx)',op_sqrt_c,0,line,0) + call dcl_proc(parser,'tan(scpx)->(scpx)',op_tan_c,0,line,0) + call dcl_proc(parser,'tanh(scpx)->(scpx)',op_tanh_c,0,line,0) + call dcl_proc(parser,'im(scpx)->(sreal)',op_imag_c,0,line,0) + call dcl_proc(parser,'conj(scpx)->(scpx)',op_conj_c,0,line,0) ! cpx type call dcl_proc(parser,'PM__assign_var(&cpx,cpx)',& op_assign_dc,0,line,0) - call dcl_proc(parser,'+(cpx,cpx)->cpx',op_add_dc,0,line,0) - call dcl_proc(parser,'-(cpx,cpx)->cpx',op_sub_dc,0,line,0) - call dcl_proc(parser,'*(cpx,cpx)->cpx',op_mult_dc,0,line,0) - call dcl_proc(parser,'/(cpx,cpx)->cpx',op_divide_dc,0,line,0) - call dcl_proc(parser,'**(cpx,real)->cpx',op_dpow_dc,0,line,0) + call dcl_proc(parser,'+(cpx,cpx)->(cpx)',op_add_dc,0,line,0) + call dcl_proc(parser,'-(cpx,cpx)->(cpx)',op_sub_dc,0,line,0) + call dcl_proc(parser,'*(cpx,cpx)->(cpx)',op_mult_dc,0,line,0) + call dcl_proc(parser,'/(cpx,cpx)->(cpx)',op_divide_dc,0,line,0) + call dcl_proc(parser,'**(cpx,real)->(cpx)',op_dpow_dc,0,line,0) call dcl_uproc(parser,'**(x:cpx,y:sreal)=x**real(y)',line) - call dcl_proc(parser,'**(cpx,cpx)->cpx',op_pow_dc,0,line,0) - call dcl_proc(parser,'-(cpx)->cpx',op_uminus_dc,0,line,0) - call dcl_proc(parser,'==(cpx,cpx)->bool',op_eq_dc,0,line,0) - call dcl_proc(parser,'/=(cpx,cpx)->bool',op_ne_dc,0,line,0) - call dcl_proc(parser,'re(cpx)->real',op_real_dc,0,line,0) - call dcl_proc(parser,'abs(cpx)->cpx',op_abs_dc,0,line,0) - call dcl_proc(parser,'acos(cpx)->cpx',op_acos_dc,0,line,0) - call dcl_proc(parser,'asin(cpx)->cpx',op_asin_dc,0,line,0) - call dcl_proc(parser,'atan(cpx)->cpx',op_atan_dc,0,line,0) - call dcl_proc(parser,'atan2(cpx,cpx)->cpx',& + call dcl_proc(parser,'**(cpx,cpx)->(cpx)',op_pow_dc,0,line,0) + call dcl_proc(parser,'-(cpx)->(cpx)',op_uminus_dc,0,line,0) + call dcl_proc(parser,'==(cpx,cpx)->(bool)',op_eq_dc,0,line,0) + call dcl_proc(parser,'/=(cpx,cpx)->(bool)',op_ne_dc,0,line,0) + call dcl_proc(parser,'re(cpx)->(real)',op_real_dc,0,line,0) + call dcl_proc(parser,'abs(cpx)->(cpx)',op_abs_dc,0,line,0) + call dcl_proc(parser,'acos(cpx)->(cpx)',op_acos_dc,0,line,0) + call dcl_proc(parser,'asin(cpx)->(cpx)',op_asin_dc,0,line,0) + call dcl_proc(parser,'atan(cpx)->(cpx)',op_atan_dc,0,line,0) + call dcl_proc(parser,'atan2(cpx,cpx)->(cpx)',& op_atan2_dc,0,line,0) - call dcl_proc(parser,'cos(cpx)->cpx',op_cos_dc,0,line,0) - call dcl_proc(parser,'cosh(cpx)->cpx',op_cosh_dc,0,line,0) - call dcl_proc(parser,'exp(cpx)->cpx',op_exp_dc,0,line,0) - call dcl_proc(parser,'log(cpx)->cpx',op_log_dc,0,line,0) - call dcl_proc(parser,'sin(cpx)->cpx',op_sin_dc,0,line,0) - call dcl_proc(parser,'sinh(cpx)->cpx',op_sinh_dc,0,line,0) - call dcl_proc(parser,'sqrt(cpx)->cpx',op_sqrt_dc,0,line,0) - call dcl_proc(parser,'tan(cpx)->cpx',op_tan_dc,0,line,0) - call dcl_proc(parser,'tanh(cpx)->cpx',op_tanh_dc,0,line,0) - call dcl_proc(parser,'im(cpx)->real',op_imag_dc,0,line,0) - call dcl_proc(parser,'conj(cpx)->cpx',op_conj_dc,0,line,0) + call dcl_proc(parser,'cos(cpx)->(cpx)',op_cos_dc,0,line,0) + call dcl_proc(parser,'cosh(cpx)->(cpx)',op_cosh_dc,0,line,0) + call dcl_proc(parser,'exp(cpx)->(cpx)',op_exp_dc,0,line,0) + call dcl_proc(parser,'log(cpx)->(cpx)',op_log_dc,0,line,0) + call dcl_proc(parser,'sin(cpx)->(cpx)',op_sin_dc,0,line,0) + call dcl_proc(parser,'sinh(cpx)->(cpx)',op_sinh_dc,0,line,0) + call dcl_proc(parser,'sqrt(cpx)->(cpx)',op_sqrt_dc,0,line,0) + call dcl_proc(parser,'tan(cpx)->(cpx)',op_tan_dc,0,line,0) + call dcl_proc(parser,'tanh(cpx)->(cpx)',op_tanh_dc,0,line,0) + call dcl_proc(parser,'im(cpx)->(real)',op_imag_dc,0,line,0) + call dcl_proc(parser,'conj(cpx)->(cpx)',op_conj_dc,0,line,0) ! Cannot convert real to int (must use nint or trunc) call dcl_uproc(parser,& @@ -754,12 +767,12 @@ subroutine sysdefs(parser) ! bool type call dcl_proc(parser,'PM__assign_var(&bool,bool)',& op_assign_l,0,line,0) - call dcl_proc(parser,'string(bool)->string',op_string_l,0,line,0) - call dcl_proc(parser,'and(bool,bool)->bool',op_and,0,line,0) - call dcl_proc(parser,'or(bool,bool)->bool',op_or,0,line,0) - call dcl_proc(parser,'not(bool)->bool',op_not,0,line,0) - call dcl_proc(parser,'==(bool,bool)->bool',op_eq_l,0,line,0) - call dcl_proc(parser,'/=(bool,bool)->bool',op_ne_l,0,line,0) + call dcl_proc(parser,'string(bool)->(string)',op_string_l,0,line,0) + call dcl_proc(parser,'and(bool,bool)->(bool)',op_and,0,line,0) + call dcl_proc(parser,'or(bool,bool)->(bool)',op_or,0,line,0) + call dcl_proc(parser,'not(bool)->(bool)',op_not,0,line,0) + call dcl_proc(parser,'==(bool,bool)->(bool)',op_eq_l,0,line,0) + call dcl_proc(parser,'/=(bool,bool)->(bool)',op_ne_l,0,line,0) !!$ ! Compile time bool values !!$ call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) @@ -808,12 +821,12 @@ subroutine sysdefs(parser) 'get(&x,y:masked(x)) {if y._there{x=y._val};return y._there}',line) ! Polymorphic types - call dcl_proc(parser,'get(x:*any,y:any)->=y',op_as,0,line,0) + call dcl_proc(parser,'get(x:*any,y:any)->(=y)',op_as,0,line,0) call dcl_proc(parser,'get(&x:any,y:*any)',op_get_poly,0,line,& proc_needs_type) - call dcl_proc(parser,'get(&x:any,y:*any)->bool',op_get_poly2,0,line,& + call dcl_proc(parser,'get(&x:any,y:*any)->(bool)',op_get_poly2,0,line,& proc_needs_type) - call dcl_proc(parser,'|(x:*any,y:any)->=y',op_get_poly_or,0,line,& + call dcl_proc(parser,'|(x:*any,y:any)->(=y)',op_get_poly_or,0,line,& proc_needs_type) ! val function having null effect @@ -1583,7 +1596,7 @@ subroutine sysdefs(parser) 'intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x)',line) call dcl_proc(parser,& - '_intersect_seq(int,int,int,int,int,int,int,int)->int,int,int,int',& + '_intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int)',& op_intersect_seq,0,line,0) call dcl_uproc(parser,'intersect(x:strided_range(any_int),y:strided_range(any_int))='//& 'new strided_range {_lo=lo,_hi=hi,_st=st,_n=n}'//& @@ -1704,11 +1717,11 @@ subroutine sysdefs(parser) op_intersect_bseq,1,line,0) call dcl_proc(parser,'_overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any)',& op_intersect_bseq,2,line,0) - call dcl_proc(parser,'_includes_aseq(any,any,any,any)->bool',& + call dcl_proc(parser,'_includes_aseq(any,any,any,any)->(bool)',& op_includes_aseq,0,line,0) - call dcl_proc(parser,'_index_aseq(any,any,any)->int',& + call dcl_proc(parser,'_index_aseq(any,any,any)->(int)',& op_index_aseq,0,line,0) - call dcl_proc(parser,'_in_aseq(any,any,any)->bool',& + call dcl_proc(parser,'_in_aseq(any,any,any)->(bool)',& op_in_aseq,0,line,0) !!$ call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq) {'//& @@ -1820,12 +1833,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_shp(x:null)=x',line) call dcl_uproc(parser,'_size(x:stretch_dim or null)=''1',line) call dcl_uproc(parser,'_size(x)=size(x)',line) - call dcl_proc(parser,'_act(x:single_point)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_act(x:single_point)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_act(x)=x',line) call dcl_uproc(parser,'_sliceit(arg...)=tuple(arg...)',line) call dcl_uproc(parser,'active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x)',line) call dcl_uproc(parser,'active_dims(x:single_point)=null',line) - call dcl_proc(parser,'_act(x:single_point,y:any)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_act(x:single_point,y:any)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_act(x,y)=y',line) call dcl_uproc(parser,'active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y)',line) call dcl_uproc(parser,'active_dims(x:single_point,y)=null',line) @@ -1873,7 +1886,7 @@ subroutine sysdefs(parser) 'map_reduce($inc,$and,x,y)',line) call dcl_uproc(parser,'#(x:grid,y:tuple(subs_dim))='//& 'map($#,x,y)',line) - call dcl_proc(parser,'_acthash(x:single_point,y:any)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_acthash(x:single_point,y:any)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_acthash(x,y)=x#y',line) call dcl_uproc(parser,'#(x:grid_slice,y:tuple(subs_dim) or grid_slice)='//& 'map_apply($_acthash,$_sliceit,x,y)',line) @@ -1896,7 +1909,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'contact(x:grid_slice,y:grid)='//& 'map($contract,x,y)',line) - call dcl_proc(parser,'gcd(x:int,y:int)->int',op_gcd,0,line,0) + call dcl_proc(parser,'gcd(x:int,y:int)->(int)',op_gcd,0,line,0) @@ -2066,7 +2079,7 @@ subroutine sysdefs(parser) '_contains(x.1,y)',line) call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim))='//& 'map_reduce($_contains,$and,x,y)',line) - call dcl_proc(parser,'_rgd(x:stretch_dim)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_rgd(x:stretch_dim)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_rgd(x)=x',line) call dcl_uproc(parser,'_rigid_dims(x:grid_slice or tuple(subs_dim))='//& 'map_apply($_rgd,$_sliceit,x)',line) @@ -2346,31 +2359,31 @@ subroutine sysdefs(parser) !!$ call dcl_uproc(parser,'PM__generate(x:mshape,n,s:schedule)=_belts(s,x)',line) call dcl_proc(parser,& - '_doloop(int)->int',& + '_doloop(int)->(int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int)->int,int',& + '_doloop(int,int)->(int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int)->int,int,int',& + '_doloop(int,int,int)->(int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int)->int,int,int,int',& + '_doloop(int,int,int,int)->(int,int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int,int)->int,int,int,int,int',& + '_doloop(int,int,int,int,int)->(int,int,int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int,int,int)->int,int,int,int,int,int',& + '_doloop(int,int,int,int,int,int)->(int,int,int,int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int,int,int,int)->'//& + '_doloop(int,int,int,int,int,int,int)->()'//& 'int,int,int,int,int,int,int',& op_do_loop,0,line,& proc_is_generator) @@ -2399,31 +2412,31 @@ subroutine sysdefs(parser) 'i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7)',line) call dcl_proc(parser,& - '_blockedloop(any)->int',& + '_blockedloop(any)->(int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int',& + '_blockedloop(any)->(int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int',& + '_blockedloop(any)->(int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int',& + '_blockedloop(any)->(int,int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int,int',& + '_blockedloop(any)->(int,int,int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int,int,int',& + '_blockedloop(any)->(int,int,int,int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->'//& + '_blockedloop(any)->()'//& 'int,int,int,int,int,int,int',& op_blocked_loop,0,line,& proc_is_generator) @@ -2454,12 +2467,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__generate(x:mshape,n,s)=_elts(dims(x),1,n)',line) call dcl_proc(parser,& - '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->int',& + '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int)',& op_iota,0,line,& proc_is_generator) call dcl_proc(parser,& '_iota(siz:int,start:int,finish:int,incr:int,'//& - 'first:int,trunc:int,totsiz:int)->int',& + 'first:int,trunc:int,totsiz:int)->(int)',& op_iota,0,line,& proc_is_generator) call dcl_uproc(parser,'_n(x:int)=x',line) @@ -2506,7 +2519,7 @@ subroutine sysdefs(parser) endif call dcl_proc(parser,& - '_indices(any)->int',op_indices,0,line,0) + '_indices(any)->(int)',op_indices,0,line,0) ! ************************************** ! ARRAYS @@ -2529,29 +2542,29 @@ subroutine sysdefs(parser) if(pm_is_compiling) then call dcl_uproc(parser,'size(x:any^mshape)=size(#x)',line) else - call dcl_proc(parser,'size(x:any^mshape)->int',op_get_size,0,line,0) + call dcl_proc(parser,'size(x:any^mshape)->(int)',op_get_size,0,line,0) endif - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->PM__dim x,y',& + call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->(PM__dim x,y)',& op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->PM__vdim x,y',& + call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->(PM__vdim x,y)',& op_var_array,0,line,proc_needs_type) -!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->(PM__invar_dim x,y)',& !!$ op_array,0,line,proc_needs_type) -!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->(PM__fix_dim x,y,z)',& !!$ merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) call dcl_proc(parser,& - '_redim(x:any^any,y:any)->over x,y',& + '_redim(x:any^any,y:any)->(over x,y)',& op_redim,0,line,proc_needs_type) - call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->PM__dim x,y',& + call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->(PM__dim x,y)',& op_array_noinit,0,line,proc_needs_type) call dcl_uproc(parser,'#%(x:invar any^any)=_array_shape(x <>)',line) call dcl_uproc(parser,'#%(x)=_get_shape(x)',line) call dcl_uproc(parser,'_get_shape(x)=#x',line) call dcl_uproc(parser,'#(x:any^any)=_array_shape(x)',line) - call dcl_proc(parser,'_array_shape(x:any^any)->#x',op_get_dom,0,line,0) + call dcl_proc(parser,'_array_shape(x:any^any)->(#x)',op_get_dom,0,line,0) call dcl_uproc(parser,'dims(x:any^mshape)=dims(#x)',line) - call dcl_proc(parser,'PM__extractelm(x:any^any)->%x',& + call dcl_proc(parser,'PM__extractelm(x:any^any)->(%x)',& op_extractelm,0,line,0) call dcl_uproc(parser,'element(a:any^mshape,t:index)='//& @@ -2560,10 +2573,10 @@ subroutine sysdefs(parser) '{ PM__setaelem(&a,index(#(a),t),v) }',line) call dcl_uproc(parser,'_make_subref(a:any^mshape,t:index)='//& '_make_subref(a,index(#(a),t))',line) - call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->%a',& + call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->(%a)',& op_make_rf,0,line,0) - call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->%x',& + call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->(%x)',& op_array_get_elem,0,line,0) call dcl_proc(parser,'PM__setaelem(&x:any^any,y:int,z:any)',& op_array_set_elem,0,line,0) @@ -3196,17 +3209,17 @@ subroutine sysdefs(parser) call dcl_type(parser,'PM__reftype(x) is x,^shared(x,,,,)',line) ! Support for internal ^(...) reference type - call dcl_proc(parser,'_v1(x:any)->PM__d1 x',op_elem,1,line,0) - call dcl_proc(parser,'_v2(x:any)->PM__d2 x',op_elem,2,line,0) - call dcl_proc(parser,'_v3(x:any)->PM__d3 x',op_elem,3,line,0) - call dcl_proc(parser,'_v4(x:any)->PM__d4 x',op_elem,4,line,0) - call dcl_proc(parser,'_v5(x:any)->PM__d5 x',op_elem,5,line,0) - - call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->PM__d1% x',op_elem,1,line,0) - call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->PM__d2% x',op_elem,2,line,0) - call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->PM__d3% x',op_elem,3,line,0) - call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->PM__d4% x',op_elem,4,line,0) - call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->PM__d5% x',op_elem,5,line,0) + call dcl_proc(parser,'_v1(x:any)->(PM__d1 x)',op_elem,1,line,0) + call dcl_proc(parser,'_v2(x:any)->(PM__d2 x)',op_elem,2,line,0) + call dcl_proc(parser,'_v3(x:any)->(PM__d3 x)',op_elem,3,line,0) + call dcl_proc(parser,'_v4(x:any)->(PM__d4 x)',op_elem,4,line,0) + call dcl_proc(parser,'_v5(x:any)->(PM__d5 x)',op_elem,5,line,0) + + call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->(PM__d1% x)',op_elem,1,line,0) + call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->(PM__d2% x)',op_elem,2,line,0) + call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->(PM__d3% x)',op_elem,3,line,0) + call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->(PM__d4% x)',op_elem,4,line,0) + call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->(PM__d5% x)',op_elem,5,line,0) ! Right hand side references call dcl_uproc(parser,'_make_null(x)=null',line) @@ -3298,7 +3311,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'_p_ref is unique',line) call dcl_proc(parser,& - '_import_dref%(r:any,s:any,h:any,x:any)->^^x',op_import_dref,0,line,0) + '_import_dref%(r:any,s:any,h:any,x:any)->(^^x)',op_import_dref,0,line,0) ! Some trivial referencing cases call dcl_uproc(parser,'PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t)',line) @@ -4613,29 +4626,29 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'topology(tp,dis,d,l:int)=tp',line) - call dcl_proc(parser,'_get_dims(int,int)->int',op_get_dims,0,& + call dcl_proc(parser,'_get_dims(int,int)->(int)',op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int)->int,int',& + call dcl_proc(parser,'_get_dims(int,int,int)->(int,int)',& op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int)->int,int,int',& + call dcl_proc(parser,'_get_dims(int,int,int,int)->(int,int,int)',& op_get_dims,0,& line,proc_is_impure) call dcl_proc(parser,& - '_get_dims(int,int,int,int,int)->int,int,int,int',& + '_get_dims(int,int,int,int,int)->(int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->'//& - 'int,int,int,int,int',& + call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->('//& + 'int,int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int',& + call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->('//& + 'int,int,int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) call dcl_proc(parser,& - '_get_dims(int,int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int,int',& + '_get_dims(int,int,int,int,int,int,int,int)->('//& + 'int,int,int,int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) @@ -4983,7 +4996,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__setelem(&a:array_slice(any^any,),v,t:index) {'//& ' _set_elem(&a._a,v,a._s[t]) }',line) - call dcl_uproc(parser,'PM__get_elem%(x:shared,i,h)=PM__getelem(x,h)',line) + call dcl_uproc(parser,'PM__get_elem%(x,i,h)=PM__getelem(x,h)',line) call dcl_uproc(parser,'PM__set_elem%(&x:invar,v:complete,i,h)'//& '{PM__setelem(&x,v,h <>);_assemble%(&x,region)}',line) @@ -5058,7 +5071,7 @@ subroutine sysdefs(parser) 'PM__makearray%(x:invar)=_makearray(x,region,size(region))'//& ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& - '_makearray(x:any,y:any,z:any)->PM__invar_dim x,y',& + '_makearray(x:any,y:any,z:any)->(PM__invar_dim x,y)',& op_make_array,0,line,proc_needs_type) else call dcl_uproc(parser,& @@ -5070,7 +5083,7 @@ subroutine sysdefs(parser) 'PM__makearray%(x:invar)=_makearray(x,region)'//& ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& - '_makearray(x:any,y:any)->PM__dim x,y',& + '_makearray(x:any,y:any)->(PM__dim x,y)',& op_make_array,0,line,proc_needs_type) !!$ call dcl_uproc(parser,'PM__correctarray(x)=_redim(PM__export endif @@ -5079,16 +5092,16 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>)',line) call dcl_uproc(parser,'_masked%(x) complete <>=masked(x)',line) call dcl_uproc(parser,'active%()=^(^??,coherent)',line) - call dcl_proc(parser,'PM__active()->bool',op_active,0,line,0) + call dcl_proc(parser,'PM__active()->(bool)',op_active,0,line,0) ! Imports and exports - call dcl_proc(parser,'_import_val(x:any)->=x',& + call dcl_proc(parser,'_import_val(x:any)->(=x)',& op_import_val,0,line,0) - call dcl_proc(parser,'PM__importshrd(x:any)->=x',& + call dcl_proc(parser,'PM__importshrd(x:any)->(=x)',& op_import_val,0,line,0) - call dcl_proc(parser,'PM__importvarg(x:any)->=x',& + call dcl_proc(parser,'PM__importvarg(x:any)->(=x)',& op_import_varg,0,line,proc_is_not_inlinable) - call dcl_proc(parser,'_import_scalar(x:any)->invar x',& + call dcl_proc(parser,'_import_scalar(x:any)->(invar x)',& op_import_scalar,0,line,0) call dcl_uproc(parser,'PM__import_val(x) {PM__checkimp(x);return _import_val(x)}',line) call dcl_uproc(parser,'PM__impscalar(x) {PM__checkimp(x);return _import_scalar(x)}',line) @@ -5164,17 +5177,17 @@ subroutine sysdefs(parser) endif ! Parallel processing inquiry - call dcl_proc(parser,'_sys_node()->int',op_sys_node,0,line,0) - call dcl_proc(parser,'sys_nnode()->int',op_sys_nnode,0,line,0) - call dcl_proc(parser,'_this_node()->int',op_this_node,1,line,0) - call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->int',op_this_node,2,line,0) - call dcl_proc(parser,'this_nnode()->int',op_this_nnode,0,line,0) - call dcl_proc(parser,'_shrd_node()->int',op_shared_node,0,line,0) - call dcl_proc(parser,'shrd_nnode()->int',op_shared_nnode,0,line,0) - call dcl_proc(parser,'_root_node()->int',op_root_node,0,line,0) - call dcl_proc(parser,'is_shrd()->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_shrd(any)->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_par()->bool',op_is_par,0,line,0) + call dcl_proc(parser,'_sys_node()->(int)',op_sys_node,0,line,0) + call dcl_proc(parser,'sys_nnode()->(int)',op_sys_nnode,0,line,0) + call dcl_proc(parser,'_this_node()->(int)',op_this_node,1,line,0) + call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->(int)',op_this_node,2,line,0) + call dcl_proc(parser,'this_nnode()->(int)',op_this_nnode,0,line,0) + call dcl_proc(parser,'_shrd_node()->(int)',op_shared_node,0,line,0) + call dcl_proc(parser,'shrd_nnode()->(int)',op_shared_nnode,0,line,0) + call dcl_proc(parser,'_root_node()->(int)',op_root_node,0,line,0) + call dcl_proc(parser,'is_shrd()->(bool)',op_is_shared,0,line,0) + call dcl_proc(parser,'is_shrd(any)->(bool)',op_is_shared,0,line,0) + call dcl_proc(parser,'is_par()->(bool)',op_is_par,0,line,0) call dcl_uproc(parser,'_head_node()=_shrd_node()==0',line) ! Parallel system nested contexts @@ -5288,32 +5301,32 @@ subroutine sysdefs(parser) 'conform(#work,#d); '//& 'var wk=work;return _wshare(wk,nnode,snode,nsnode) }',line) call dcl_proc(parser,& - '_wshare(int^any,int,int,int)->int',op_wshare,0,line,0) + '_wshare(int^any,int,int,int)->(int)',op_wshare,0,line,0) ! ************************************************************* ! I/O OPERATIONS ! ************************************************************* ! Built-in operators - call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->sint,sint',& + call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->(sint,sint)',& op_open_file,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_close_file(sint)->sint',& + call dcl_proc(parser,'_close_file(sint)->(sint)',& op_close_file,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_seek_file(sint,lint)->sint',& + call dcl_proc(parser,'_seek_file(sint,lint)->(sint)',& op_seek_file,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_read_file(sint,&any)->sint',& + call dcl_proc(parser,'_read_file(sint,&any)->(sint)',& op_read_file,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_write_file(sint,any)->sint',& + call dcl_proc(parser,'_write_file(sint,any)->(sint)',& op_write_file,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_read_file_array(sint,&any,int)->sint',& + call dcl_proc(parser,'_read_file_array(sint,&any,int)->(sint)',& op_read_file_array,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_write_file_array(sint,any,int)->sint',& + call dcl_proc(parser,'_write_file_array(sint,any,int)->(sint)',& op_write_file_array,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->sint',& + call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->(sint)',& op_read_file_tile,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->sint',& + call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->(sint)',& op_write_file_tile,0,line,proc_is_impure+proc_is_file) - call dcl_proc(parser,'_io_error_string(sint)->string',& + call dcl_proc(parser,'_io_error_string(sint)->(string)',& op_io_error_string,0,line,proc_is_impure) ! IO/related types @@ -5605,12 +5618,12 @@ subroutine sysdefs(parser) call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',op_broadcast,& 0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'PM__broadcast(b:any,a:int)->=b',op_broadcast_val,& + call dcl_proc(parser,'PM__broadcast(b:any,a:int)->(=b)',op_broadcast_val,& 0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,& 'get_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& - 'b:int,c:int)->%a',& + 'b:int,c:int)->(%a)',& op_get_remote_distr,& 0,line,proc_is_impure+proc_is_dcomm) @@ -5649,7 +5662,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'max(x:real_num^any,y:real_num)=map_const($max,x,y)',line) call dcl_uproc(parser,'min(x:real_num^any,y:real_num)=map_const($min,x,y)',line) - call dcl_proc(parser,'_pack(v:any,any,any,d:any)->PM__dim v,d',& + call dcl_proc(parser,'_pack(v:any,any,any,d:any)->(PM__dim v,d)',& op_pack,0,line,0) call dcl_uproc(parser,'pack(v:any^mshape,m:bool^mshape) { '//& ' test "arrays do not conform"=>conform(#v,#m); '//& @@ -5807,15 +5820,15 @@ subroutine sysdefs(parser) call dcl_proc(parser,'_assign_element(&any,any)',op_assign,0,line,0) ! Other variable operations - call dcl_proc(parser,'PM__clone(x:any)->=x',op_clone,0,line,0) + call dcl_proc(parser,'PM__clone(x:any)->(=x)',op_clone,0,line,0) call dcl_uproc(parser,'PM__dup(PM__dup) <>=PM__clone(PM__dup)',line) - call dcl_proc(parser,'PM__dup(x:fix int)->int',op_clone,0,line,0) - call dcl_proc(parser,'PM__dup(x:fix real)->real',op_clone,0,line,0) - call dcl_proc(parser,'PM__dup(x:fix string)->string',op_clone,0,line,0) - call dcl_proc(parser,'PM__dup(x:fix bool)->bool',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix int)->(int)',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix real)->(real)',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix string)->(string)',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix bool)->(bool)',op_clone,0,line,0) - call dcl_proc(parser,'PM__getref(x:any)->=x',op_get_rf,0,line,0) - call dcl_proc(parser,'same_type(x:any,y:any)->==x,y',& + call dcl_proc(parser,'PM__getref(x:any)->(=x)',op_get_rf,0,line,0) + call dcl_proc(parser,'same_type(x:any,y:any)->(==x,y)',& op_logical_return,0,line,proc_needs_type) call dcl_uproc(parser,'==(x:any,y:any) {'//& 'test "Cannot apply ""=="" to different types"=> same_type(x,y);'//& @@ -5825,21 +5838,21 @@ subroutine sysdefs(parser) 'var ok=true;_eq(x,y,&ok);return not ok}',line) call dcl_uproc(parser,& '_eq(x:any,y:any,&ok) <> { ok=ok and x==y }',line) - call dcl_proc(parser,'PM__copy_out(x:any)->=x',op_clone,0,line,0) - call dcl_proc(parser,'PM__copy_back(x:any)->=x',op_assign,0,line,0) + call dcl_proc(parser,'PM__copy_out(x:any)->(=x)',op_clone,0,line,0) + call dcl_proc(parser,'PM__copy_back(x:any)->(=x)',op_assign,0,line,0) call dcl_uproc(parser,'next_enum(x:int)=x+convert(1,x)',line) call dcl_uproc(parser,'next_enum(x:int,y:int)=x+convert(y,x)',line) ! Type values - call dcl_proc(parser,'typeof(x:any)->type x',op_make_type_val,0,line,proc_needs_type) + call dcl_proc(parser,'typeof(x:any)->(type x)',op_make_type_val,0,line,proc_needs_type) call dcl_uproc(parser,'is(x,t)=t inc typeof(x)',line) call dcl_uproc(parser,'isnt(x,t)=not(x is t)',line) call dcl_uproc(parser,'as(x,t:)...=PM__cast(x,t)',line) call dcl_uproc(parser,'as(x,t)=PM__cast(x,typeof(t))',line) - call dcl_proc(parser,'inc(x:,y:)-> inc x,y',op_logical_return,0,line,proc_needs_type) + call dcl_proc(parser,'inc(x:,y:)->( inc x,y)',op_logical_return,0,line,proc_needs_type) call dcl_uproc(parser,'==(x:,y:)=x inc y and y inc x',line) - call dcl_proc(parser,'error_type()->?0',0,0,line,proc_needs_type) + call dcl_proc(parser,'error_type()->(?0)',0,0,line,proc_needs_type) ! Debugging call dcl_proc(parser,'_dump(any,any)',op_new_dump,0,line,proc_is_impure) diff --git a/src/sysdefs_make.f90 b/src/sysdefs_make.f90 new file mode 100755 index 0000000..1d4c537 --- /dev/null +++ b/src/sysdefs_make.f90 @@ -0,0 +1,5917 @@ +program make_sysmod + integer,parameter:: proc_is_comm= 1 + integer,parameter:: proc_is_open= 128 + integer,parameter:: proc_is_each_proc= 256 + integer,parameter:: proc_is_cond= 512 + integer,parameter:: proc_is_uncond= 1024 + integer,parameter:: proc_is_abstract= 2048 + integer,parameter:: proc_is_thru_each = 2**12 + integer,parameter:: proc_is_empty_each = 2**13 + integer,parameter:: proc_is_dup_each = 2**14 + integer,parameter:: proc_is_var = 2**15 + integer,parameter:: proc_is_generator = 2**16 + integer,parameter:: proc_needs_type = 2**17 + integer,parameter:: proc_is_recursive = 2**18 + integer,parameter:: proc_is_impure = 2**20 + integer,parameter:: proc_is_not_inlinable = 2**21 + integer,parameter:: proc_has_for = 2**22 + integer,parameter:: proc_is_not_pure_each = 2**23 + integer,parameter:: proc_has_vkeys = 2**24 + integer,parameter:: proc_is_dcomm = 2**25 + integer,parameter:: proc_is_file = 2**26 + + logical,parameter:: pm_is_compiling=.false. + + integer parser,line + + call dcl_type(parser,'literal is ^^^any',line) + call dcl_type(parser,'int_literal is ^^^int',line) + call dcl_type(parser,'real_literal is ^^^real',line) + call dcl_type(parser,'bool_literal is ^^^bool',line) + call dcl_type(parser,'string_literal is ^^^string',line) + + call dcl_proc(parser,'mod(int_literal,int_literal)->int_literal',"mod_fold",0,line,0) + call dcl_proc(parser,'==(int_literal,int_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(int_literal,int_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'>=(int_literal,int_literal)->bool_literal',"ge_fold",0,line,0) + call dcl_proc(parser,'>(int_literal,int_literal)->bool_literal',"gt_fold",0,line,0) + call dcl_proc(parser,'+(int_literal,int_literal)->int_literal',"add_fold",0,line,0) + call dcl_proc(parser,'-(int_literal,int_literal)->int_literal',"sub_fold",0,line,0) + call dcl_proc(parser,'*(int_literal,int_literal)->int_literal',"mult_fold",0,line,0) + call dcl_proc(parser,'/(int_literal,int_literal)->int_literal',"divide_fold",0,line,0) + call dcl_proc(parser,'**(int_literal,int_literal)->int_literal',"pow_fold",0,line,0) + call dcl_proc(parser,'max(int_literal,int_literal)->int_literal',"max_fold",0,line,0) + call dcl_proc(parser,'min(int_literal,int_literal)->int_literal',"min_fold",0,line,0) + call dcl_proc(parser,'-(int_literal)->int_literal',"uminus_fold",0,line,0) + call dcl_proc(parser,'string(int_literal)->string',"string_fold",0,line,0) + call dcl_proc(parser,'abs(int_literal)->int_literal',"abs_fold",0,line,0) + call dcl_proc(parser,'~(int_literal)->int_literal',"bnot_fold",0,line,0) + call dcl_proc(parser,'&(int_literal,int_literal)->int_literal',"band_fold",0,line,0) + call dcl_proc(parser,'|(int_literal,int_literal)->int_literal',"bor_fold",0,line,0) + call dcl_proc(parser,'xor(int_literal,int_literal)->int_literal',"bxor_fold",0,line,0) + call dcl_proc(parser,'shift(int_literal,int_literal)->int_literal',& + "bshift_fold",0,line,0) + call dcl_proc(parser,'pdiff(int_literal,int_literal)->int_literal',"pdiff_fold",0,line,0) + call dcl_proc(parser,'sign(int_literal,int_literal)->int_literal',"sign_fold",0,line,0) + call dcl_proc(parser,'rem(int_literal,int_literal)->int_literal',"modulo_fold",0,line,0) + call dcl_proc(parser,'and(bool_literal,bool_literal)->bool_literal',"and_fold",0,line,0) + call dcl_proc(parser,'or(bool_literal,bool_literal)->bool_literal',"or_fold",0,line,0) + call dcl_proc(parser,'except(bool_literal,bool_literal)->bool_literal',"except_fold",0,line,0) + call dcl_proc(parser,'==(bool_literal,bool_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(bool_literal,bool_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'==(string_literal,string_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(string_literal,string_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'==(real_literal,real_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(real_literal,real_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'++(string_literal,string_literal)->string_literal',"concat_fold",0,line,0) + + call dcl_proc(parser,'mod(fix int,fix int)->fix int',"mod_fold",0,line,0) + call dcl_proc(parser,'==(fix int,fix int)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix int,fix int)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'>=(fix int,fix int)->fix bool',"ge_fold",0,line,0) + call dcl_proc(parser,'>(fix int,fix int)->fix bool',"gt_fold",0,line,0) + call dcl_proc(parser,'+(fix int,fix int)->fix int',"add_fold",0,line,0) + call dcl_proc(parser,'-(fix int,fix int)->fix int',"sub_fold",0,line,0) + call dcl_proc(parser,'*(fix int,fix int)->fix int',"mult_fold",0,line,0) + call dcl_proc(parser,'/(fix int,fix int)->fix int',"divide_fold",0,line,0) + call dcl_proc(parser,'**(fix int,fix int)->fix int',"pow_fold",0,line,0) + call dcl_proc(parser,'max(fix int,fix int)->fix int',"max_fold",0,line,0) + call dcl_proc(parser,'min(fix int,fix int)->fix int',"min_fold",0,line,0) + call dcl_proc(parser,'-(fix int)->fix int',"uminus_fold",0,line,0) + call dcl_proc(parser,'string(fix int)->string',"string_fold",0,line,0) + call dcl_proc(parser,'abs(fix int)->fix int',"abs_fold",0,line,0) + call dcl_proc(parser,'~(fix int)->fix int',"bnot_fold",0,line,0) + call dcl_proc(parser,'&(fix int,fix int)->fix int',"band_fold",0,line,0) + call dcl_proc(parser,'|(fix int,fix int)->fix int',"bor_fold",0,line,0) + call dcl_proc(parser,'xor(fix int,fix int)->fix int',"bxor_fold",0,line,0) + call dcl_proc(parser,'shift(fix int,fix int)->fix int',& + "bshift_fold",0,line,0) + call dcl_proc(parser,'pdiff(fix int,fix int)->fix int',"pdiff_fold",0,line,0) + call dcl_proc(parser,'sign(fix int,fix int)->fix int',"sign_fold",0,line,0) + call dcl_proc(parser,'rem(fix int,fix int)->fix int',"modulo_fold",0,line,0) + call dcl_proc(parser,'and(fix bool,fix bool)->fix bool',"and_fold",0,line,0) + call dcl_proc(parser,'or(fix bool,fix bool)->fix bool',"or_fold",0,line,0) + call dcl_proc(parser,'except(fix bool,fix bool)->fix bool',"except_fold",0,line,0) + call dcl_proc(parser,'==(fix bool,fix bool)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix bool,fix bool)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'==(fix string,fix string)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix string,fix string)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'==(fix real,fix real)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix real,fix real)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'++(fix string,fix string)->fix string',"concat_fold",0,line,0) + +write(*,'(a)') '// **************************************' +WRITE(*,'(A)') '// BASIC TYPES' +write(*,'(a)') '// **************************************' + +write(*,'(a)') '// String type' + call dcl_proc(parser,'print(string)',"print",0,line,proc_is_impure) + call dcl_uproc(parser,'print(x) { print(string(x)) }',line) + call dcl_proc(parser,'print_all(string)',"print",1,line,proc_is_impure) + call dcl_uproc(parser,'print_all(x) { print_all(string(x)) }',line) + call dcl_proc(parser,'++(string,string)->string',"concat",0,line,0) + call dcl_uproc(parser,'++(x:string,y)=$++.(x,string(y))',line) + call dcl_uproc(parser,'++(x,y)=$++.(string(x),string(y))',line) + call dcl_uproc(parser,'string(x:string)=x',line) + call dcl_uproc(parser,'string(x:null)="null"',line) + call dcl_uproc(parser,'fmt(x,y)=x:test """fmt"" operator not yet implmented"=>''false',line) + +write(*,'(a)') '// sint type' + call dcl_proc(parser,'PM__assign_var(&sint,sint)',& + "assign_i",0,line,0) + call dcl_proc(parser,'mod(sint,sint)->sint',"mod_i",0,line,0) + call dcl_proc(parser,'==(sint,sint)->bool',"eq_i",0,line,0) + call dcl_proc(parser,'/=(sint,sint)->bool',"ne_i",0,line,0) + call dcl_proc(parser,'>=(sint,sint)->bool',"ge_i",0,line,0) + call dcl_proc(parser,'>(sint,sint)->bool',"gt_i",0,line,0) + call dcl_proc(parser,'+(sint,sint)->sint',"add_i",0,line,0) + call dcl_proc(parser,'-(sint,sint)->sint',"sub_i",0,line,0) + call dcl_proc(parser,'*(sint,sint)->sint',"mult_i",0,line,0) + call dcl_proc(parser,'/(sint,sint)->sint',"divide_i",0,line,0) + call dcl_proc(parser,'**(sint,sint)->sint',"pow_i",0,line,0) + call dcl_proc(parser,'max(sint,sint)->sint',"max_i",0,line,0) + call dcl_proc(parser,'min(sint,sint)->sint',"min_i",0,line,0) + call dcl_proc(parser,'-(sint)->sint',"uminus_i",0,line,0) + call dcl_proc(parser,'string(sint)->string',"string_i",0,line,0) + call dcl_proc(parser,'int(sint)->int',"long_i",0,line,0) + call dcl_proc(parser,'sreal(sint)->sreal',"real_i",0,line,0) + call dcl_proc(parser,'real(sint)->real',"double_i",0,line,0) + call dcl_uproc(parser,'sint(x:sint)=x',line) + call dcl_proc(parser,'abs(sint)->sint',"abs_i",0,line,0) + call dcl_proc(parser,'bit_not(sint)->sint',"bnot_i",0,line,0) + call dcl_proc(parser,'&(sint,sint)->sint',"band_i",0,line,0) + call dcl_proc(parser,'|(sint,sint)->sint',"bor_i",0,line,0) + call dcl_proc(parser,'xor(sint,sint)->sint',"bxor_i",0,line,0) + call dcl_proc(parser,'shift(sint,sint)->sint',"bshift_i",0,line,0) + call dcl_proc(parser,'pdiff(sint,sint)->sint',"pdiff_i",0,line,0) + call dcl_proc(parser,'sign(sint,sint)->sint',"sign_i",0,line,0) + call dcl_proc(parser,'rem(sint,sint)->sint',"modulo_i",0,line,0) + call dcl_proc(parser,'int8(sint)->int8',"i8_i",0,line,0) + call dcl_proc(parser,'int16(sint)->int16',"i16_i",0,line,0) + call dcl_proc(parser,'int32(sint)->int32',"i32_i",0,line,0) + call dcl_proc(parser,'int64(sint)->int64',"i64_i",0,line,0) + call dcl_proc(parser,'lint(sint)->lint',"offset_i",0,line,0) + +write(*,'(a)') '// int type' + call dcl_proc(parser,'PM__assign_var(&int,int)',& + "assign_ln",0,line,0) + call dcl_proc(parser,'mod(int,int)->int',"mod_ln",0,line,0) + call dcl_proc(parser,'==(int,int)->bool',"eq_ln",0,line,0) + call dcl_proc(parser,'/=(int,int)->bool',"ne_ln",0,line,0) + call dcl_proc(parser,'>=(int,int)->bool',"ge_ln",0,line,0) + call dcl_proc(parser,'>(int,int)->bool',"gt_ln",0,line,0) + call dcl_proc(parser,'+(int,int)->int',"add_ln",0,line,0) +!!$ call dcl_uproc(parser,'+(x:int,y:''0)=x',line) +!!$ call dcl_uproc(parser,'+(x:''0,y:int)=y',line) + call dcl_proc(parser,'-(int,int)->int',"sub_ln",0,line,0) +!!$ call dcl_uproc(parser,'-(x:int,y:''0)=x',line) + call dcl_proc(parser,'*(int,int)->int',"mult_ln",0,line,0) + call dcl_uproc(parser,'*(x:int,y:''1)=x',line) +!!$ call dcl_uproc(parser,'*(x:''1,y:int)=y',line) + call dcl_proc(parser,'/(int,int)->int',"divide_ln",0,line,0) + call dcl_uproc(parser,'/(x:int,y:''1)=x',line) + call dcl_proc(parser,'**(int,int)->int',"pow_ln",0,line,0) +!!$ call dcl_uproc(parser,'**(x:int,y:''0)=1',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''1)=x',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) + call dcl_proc(parser,'max(int,int)->int',"max_ln",0,line,0) + call dcl_proc(parser,'min(int,int)->int',"min_ln",0,line,0) + call dcl_proc(parser,'-(int)->int',"uminus_ln",0,line,0) + call dcl_proc(parser,'string(int)->string',"string_ln",0,line,0) + call dcl_proc(parser,'sint(int)->sint',"int_ln",0,line,0) + call dcl_proc(parser,'sreal(int)->sreal',"real_ln",0,line,0) + call dcl_proc(parser,'real(int)->real',"double_ln",0,line,0) + call dcl_uproc(parser,'int(x:int)=x',line) + call dcl_proc(parser,'abs(int)->int',"abs_ln",0,line,0) + call dcl_proc(parser,'~(int)->int',"bnot_ln",0,line,0) + call dcl_proc(parser,'&(int,int)->int',"band_ln",0,line,0) + call dcl_proc(parser,'|(int,int)->int',"bor_ln",0,line,0) + call dcl_proc(parser,'xor(int,int)->int',"bxor_ln",0,line,0) + call dcl_proc(parser,'shift(int,int)->int',& + "bshift_ln",0,line,0) + call dcl_proc(parser,'pdiff(int,int)->int',"pdiff_ln",0,line,0) + call dcl_proc(parser,'sign(int,int)->int',"sign_ln",0,line,0) + call dcl_proc(parser,'rem(int,int)->int',"modulo_ln",0,line,0) + call dcl_proc(parser,'int8(int)->int8',"i8_ln",0,line,0) + call dcl_proc(parser,'int16(int)->int16',"i16_ln",0,line,0) + call dcl_proc(parser,'int32(int)->int32',"i32_ln",0,line,0) + call dcl_proc(parser,'int64(int)->int64',"i64_ln",0,line,0) + call dcl_proc(parser,'lint(int)->lint',"offset_ln",0,line,0) + +write(*,'(a)') '// lint type' + call dcl_proc(parser,'PM__assign_var(&lint,lint)',& + "assign_offset",0,line,0) + call dcl_proc(parser,'mod(lint,lint)->lint',"mod_offset",0,line,0) + call dcl_proc(parser,'==(lint,lint)->bool',"eq_offset",0,line,0) + call dcl_proc(parser,'/=(lint,lint)->bool',"ne_offset",0,line,0) + call dcl_proc(parser,'>=(lint,lint)->bool',"ge_offset",0,line,0) + call dcl_proc(parser,'>(lint,lint)->bool',"gt_offset",0,line,0) + call dcl_proc(parser,'+(lint,lint)->lint',"add_offset",0,line,0) + call dcl_uproc(parser,'+(x:lint,y:''0)=x',line) + call dcl_uproc(parser,'+(x:''0,y:lint)=y',line) + call dcl_proc(parser,'-(lint,lint)->lint',"sub_offset",0,line,0) + call dcl_uproc(parser,'-(x:lint,y:''0)=x',line) + call dcl_proc(parser,'*(lint,lint)->lint',"mult_offset",0,line,0) + call dcl_uproc(parser,'*(x:lint,y:''1)=x',line) + call dcl_uproc(parser,'*(x:''1,y:lint)=y',line) + call dcl_proc(parser,'/(lint,lint)->lint',"divide_offset",0,line,0) + call dcl_uproc(parser,'/(x:lint,y:''1)=x',line) + call dcl_proc(parser,'**(lint,lint)->lint',"pow_offset",0,line,0) + call dcl_uproc(parser,'**(x:lint,y:''0)=1',line) + call dcl_uproc(parser,'**(x:lint,y:''1)=x',line) + call dcl_uproc(parser,'**(x:lint,y:''2)=x*x',line) + call dcl_proc(parser,'max(lint,lint)->lint',"max_offset",0,line,0) + call dcl_proc(parser,'min(lint,lint)->lint',"min_offset",0,line,0) + call dcl_proc(parser,'-(lint)->lint',"uminus_offset",0,line,0) + call dcl_proc(parser,'string(lint)->string',"string_offset",0,line,0) + call dcl_proc(parser,'sint(lint)->sint',"int_offset",0,line,0) + call dcl_proc(parser,'sreal(lint)->sreal',"real_offset",0,line,0) + call dcl_proc(parser,'real(lint)->real',"double_offset",0,line,0) + call dcl_uproc(parser,'lint(x:lint)=x',line) + call dcl_proc(parser,'abs(lint)->lint',"abs_offset",0,line,0) + call dcl_proc(parser,'~(lint)->lint',"bnot_offset",0,line,0) + call dcl_proc(parser,'&(lint,lint)->lint',"band_offset",0,line,0) + call dcl_proc(parser,'|(lint,lint)->lint',"bor_offset",0,line,0) + call dcl_proc(parser,'xor(lint,lint)->lint',"bxor_offset",0,line,0) + call dcl_proc(parser,'shift(lint,lint)->lint',& + "bshift_offset",0,line,0) + call dcl_proc(parser,'pdiff(lint,lint)->lint',"pdiff_offset",0,line,0) + call dcl_proc(parser,'sign(lint,lint)->lint',"sign_offset",0,line,0) + call dcl_proc(parser,'rem(lint,lint)->lint',"modulo_offset",0,line,0) + call dcl_proc(parser,'int8(lint)->int8',"i8_offset",0,line,0) + call dcl_proc(parser,'int16(lint)->int16',"i16_offset",0,line,0) + call dcl_proc(parser,'int32(lint)->int32',"i32_offset",0,line,0) + call dcl_proc(parser,'int64(lint)->int64',"i64_offset",0,line,0) + call dcl_proc(parser,'int(lint)->int',"long_offset",0,line,0) + +write(*,'(a)') '// int8 type' + call dcl_proc(parser,'PM__assign_var(&int8,int8)',& + "assign_i8",0,line,0) + call dcl_proc(parser,'mod(int8,int8)->int8',"mod_i8",0,line,0) + call dcl_proc(parser,'==(int8,int8)->bool',"eq_i8",0,line,0) + call dcl_proc(parser,'/=(int8,int8)->bool',"ne_i8",0,line,0) + call dcl_proc(parser,'>=(int8,int8)->bool',"ge_i8",0,line,0) + call dcl_proc(parser,'>(int8,int8)->bool',"gt_i8",0,line,0) + call dcl_proc(parser,'+(int8,int8)->int8',"add_i8",0,line,0) + call dcl_uproc(parser,'+(x:int8,y:''0)=x',line) + call dcl_uproc(parser,'+(x:''0,y:int8)=y',line) + call dcl_proc(parser,'-(int8,int8)->int8',"sub_i8",0,line,0) + call dcl_uproc(parser,'-(x:int8,y:''0)=x',line) + call dcl_proc(parser,'*(int8,int8)->int8',"mult_i8",0,line,0) + call dcl_uproc(parser,'*(x:int8,y:''1)=x',line) + call dcl_uproc(parser,'*(x:''1,y:int8)=y',line) + call dcl_proc(parser,'/(int8,int8)->int8',"divide_i8",0,line,0) + call dcl_uproc(parser,'/(x:int8,y:''1)=x',line) + call dcl_proc(parser,'**(int8,int8)->int8',"pow_i8",0,line,0) + call dcl_uproc(parser,'**(x:int8,y:''0)=1',line) + call dcl_uproc(parser,'**(x:int8,y:''1)=x',line) + call dcl_uproc(parser,'**(x:int8,y:''2)=x*x',line) + call dcl_proc(parser,'max(int8,int8)->int8',"max_i8",0,line,0) + call dcl_proc(parser,'min(int8,int8)->int8',"min_i8",0,line,0) + call dcl_proc(parser,'-(int8)->int8',"uminus_i8",0,line,0) + call dcl_proc(parser,'sint(int8)->sint',"int_i8",0,line,0) + call dcl_proc(parser,'sreal(int8)->sreal',"real_i8",0,line,0) + call dcl_proc(parser,'real(int8)->real',"double_i8",0,line,0) + call dcl_uproc(parser,'int8(x:int8)=x',line) + call dcl_proc(parser,'abs(int8)->int8',"abs_i8",0,line,0) + call dcl_proc(parser,'~(int8)->int8',"bnot_i8",0,line,0) + call dcl_proc(parser,'&(int8,int8)->int8',"band_i8",0,line,0) + call dcl_proc(parser,'|(int8,int8)->int8',"bor_i8",0,line,0) + call dcl_proc(parser,'xor(int8,int8)->int8',"bxor_i8",0,line,0) + call dcl_proc(parser,'shift(int8,int8)->int8',& + "bshift_i8",0,line,0) + call dcl_proc(parser,'pdiff(int8,int8)->int8',"pdiff_i8",0,line,0) + call dcl_proc(parser,'sign(int8,int8)->int8',"sign_i8",0,line,0) + call dcl_proc(parser,'rem(int8,int8)->int8',"modulo_i8",0,line,0) + call dcl_proc(parser,'int16(int8)->int16',"i16_i8",0,line,0) + call dcl_proc(parser,'int32(int8)->int32',"i32_i8",0,line,0) + call dcl_proc(parser,'int64(int8)->int64',"i64_i8",0,line,0) + call dcl_proc(parser,'int(int8)->int',"long_i8",0,line,0) + call dcl_proc(parser,'lint(int8)->lint',"offset_i8",0,line,0) + +write(*,'(a)') '// int16 type' + call dcl_proc(parser,'PM__assign_var(&int16,int16)',& + "assign_i16",0,line,0) + call dcl_proc(parser,'mod(int16,int16)->int16',"mod_i16",0,line,0) + call dcl_proc(parser,'==(int16,int16)->bool',"eq_i16",0,line,0) + call dcl_proc(parser,'/=(int16,int16)->bool',"ne_i16",0,line,0) + call dcl_proc(parser,'>=(int16,int16)->bool',"ge_i16",0,line,0) + call dcl_proc(parser,'>(int16,int16)->bool',"gt_i16",0,line,0) + call dcl_proc(parser,'+(int16,int16)->int16',"add_i16",0,line,0) + call dcl_uproc(parser,'+(x:int16,y:''0)=x',line) + call dcl_uproc(parser,'+(x:''0,y:int16)=y',line) + call dcl_proc(parser,'-(int16,int16)->int16',"sub_i16",0,line,0) + call dcl_uproc(parser,'-(x:int16,y:''0)=x',line) + call dcl_proc(parser,'*(int16,int16)->int16',"mult_i16",0,line,0) + call dcl_uproc(parser,'*(x:int16,y:''1)=x',line) + call dcl_uproc(parser,'*(x:''1,y:int16)=y',line) + call dcl_proc(parser,'/(int16,int16)->int16',"divide_i16",0,line,0) + call dcl_uproc(parser,'/(x:int16,y:''1)=x',line) + call dcl_proc(parser,'**(int16,int16)->int16',"pow_i16",0,line,0) + call dcl_uproc(parser,'**(x:int16,y:''0)=1',line) + call dcl_uproc(parser,'**(x:int16,y:''1)=x',line) + call dcl_uproc(parser,'**(x:int16,y:''2)=x*x',line) + call dcl_proc(parser,'max(int16,int16)->int16',"max_i16",0,line,0) + call dcl_proc(parser,'min(int16,int16)->int16',"min_i16",0,line,0) + call dcl_proc(parser,'-(int16)->int16',"uminus_i16",0,line,0) + call dcl_proc(parser,'sint(int16)->sint',"int_i16",0,line,0) + call dcl_proc(parser,'sreal(int16)->sreal',"real_i16",0,line,0) + call dcl_proc(parser,'real(int16)->real',"double_i16",0,line,0) + call dcl_uproc(parser,'int16(x:int16)=x',line) + call dcl_proc(parser,'abs(int16)->int16',"abs_i16",0,line,0) + call dcl_proc(parser,'~(int16)->int16',"bnot_i16",0,line,0) + call dcl_proc(parser,'&(int16,int16)->int16',"band_i16",0,line,0) + call dcl_proc(parser,'|(int16,int16)->int16',"bor_i16",0,line,0) + call dcl_proc(parser,'xor(int16,int16)->int16',"bxor_i16",0,line,0) + call dcl_proc(parser,'shift(int16,int16)->int16',& + "bshift_i16",0,line,0) + call dcl_proc(parser,'pdiff(int16,int16)->int16',"pdiff_i16",0,line,0) + call dcl_proc(parser,'sign(int16,int16)->int16',"sign_i16",0,line,0) + call dcl_proc(parser,'rem(int16,int16)->int16',"modulo_i16",0,line,0) + call dcl_proc(parser,'int8(int16)->int16',"i8_i16",0,line,0) + call dcl_proc(parser,'int32(int16)->int32',"i32_i16",0,line,0) + call dcl_proc(parser,'int64(int16)->int64',"i64_i16",0,line,0) + call dcl_proc(parser,'int(int16)->int',"long_i16",0,line,0) + call dcl_proc(parser,'lint(int16)->lint',"offset_i16",0,line,0) + +write(*,'(a)') '// int32 type' + call dcl_proc(parser,'PM__assign_var(&int32,int32)',& + "assign_i32",0,line,0) + call dcl_proc(parser,'mod(int32,int32)->int32',"mod_i32",0,line,0) + call dcl_proc(parser,'==(int32,int32)->bool',"eq_i32",0,line,0) + call dcl_proc(parser,'/=(int32,int32)->bool',"ne_i32",0,line,0) + call dcl_proc(parser,'>=(int32,int32)->bool',"ge_i32",0,line,0) + call dcl_proc(parser,'>(int32,int32)->bool',"gt_i32",0,line,0) + call dcl_proc(parser,'+(int32,int32)->int32',"add_i32",0,line,0) + call dcl_uproc(parser,'+(x:int32,y:''0)=x',line) + call dcl_uproc(parser,'+(x:''0,y:int32)=y',line) + call dcl_proc(parser,'-(int32,int32)->int32',"sub_i32",0,line,0) + call dcl_uproc(parser,'-(x:int32,y:''0)=x',line) + call dcl_proc(parser,'*(int32,int32)->int32',"mult_i32",0,line,0) + call dcl_uproc(parser,'*(x:int32,y:''1)=x',line) + call dcl_uproc(parser,'*(x:''1,y:int32)=y',line) + call dcl_proc(parser,'/(int32,int32)->int32',"divide_i32",0,line,0) + call dcl_uproc(parser,'/(x:int32,y:''1)=x',line) + call dcl_proc(parser,'**(int32,int32)->int32',"pow_i32",0,line,0) + call dcl_uproc(parser,'**(x:int32,y:''0)=1',line) + call dcl_uproc(parser,'**(x:int32,y:''1)=x',line) + call dcl_uproc(parser,'**(x:int32,y:''2)=x*x',line) + call dcl_proc(parser,'max(int32,int32)->int32',"max_i32",0,line,0) + call dcl_proc(parser,'min(int32,int32)->int32',"min_i32",0,line,0) + call dcl_proc(parser,'-(int32)->int32',"uminus_i32",0,line,0) + call dcl_proc(parser,'sint(int32)->sint',"int_i32",0,line,0) + call dcl_proc(parser,'sreal(int32)->sreal',"real_i32",0,line,0) + call dcl_proc(parser,'real(int32)->real',"double_i32",0,line,0) + call dcl_uproc(parser,'int32(x:int32)=x',line) + call dcl_proc(parser,'abs(int32)->int32',"abs_i32",0,line,0) + call dcl_proc(parser,'~(int32)->int32',"bnot_i32",0,line,0) + call dcl_proc(parser,'&(int32,int32)->int32',"band_i32",0,line,0) + call dcl_proc(parser,'|(int32,int32)->int32',"bor_i32",0,line,0) + call dcl_proc(parser,'xor(int32,int32)->int32',"bxor_i32",0,line,0) + call dcl_proc(parser,'shift(int32,int32)->int32',& + "bshift_i32",0,line,0) + call dcl_proc(parser,'pdiff(int32,int32)->int32',"pdiff_i32",0,line,0) + call dcl_proc(parser,'sign(int32,int32)->int32',"sign_i32",0,line,0) + call dcl_proc(parser,'rem(int32,int32)->int32',"modulo_i32",0,line,0) + call dcl_proc(parser,'int8(int32)->int32',"i8_i32",0,line,0) + call dcl_proc(parser,'int16(int32)->int32',"i16_i32",0,line,0) + call dcl_proc(parser,'int64(int32)->int64',"i64_i32",0,line,0) + call dcl_proc(parser,'int(int32)->int',"long_i32",0,line,0) + call dcl_proc(parser,'lint(int32)->lint',"offset_i32",0,line,0) + +write(*,'(a)') '// int64 type' + call dcl_proc(parser,'PM__assign_var(&int64,int64)',& + "assign_i64",0,line,0) + call dcl_proc(parser,'mod(int64,int64)->int64',"mod_i64",0,line,0) + call dcl_proc(parser,'==(int64,int64)->bool',"eq_i64",0,line,0) + call dcl_proc(parser,'/=(int64,int64)->bool',"ne_i64",0,line,0) + call dcl_proc(parser,'>=(int64,int64)->bool',"ge_i64",0,line,0) + call dcl_proc(parser,'>(int64,int64)->bool',"gt_i64",0,line,0) + call dcl_proc(parser,'+(int64,int64)->int64',"add_i64",0,line,0) + call dcl_uproc(parser,'+(x:int64,y:''0)=x',line) + call dcl_uproc(parser,'+(x:''0,y:int64)=y',line) + call dcl_proc(parser,'-(int64,int64)->int64',"sub_i64",0,line,0) + call dcl_uproc(parser,'-(x:int64,y:''0)=x',line) + call dcl_proc(parser,'*(int64,int64)->int64',"mult_i64",0,line,0) + call dcl_uproc(parser,'*(x:int64,y:''1)=x',line) + call dcl_uproc(parser,'*(x:''1,y:int64)=y',line) + call dcl_proc(parser,'/(int64,int64)->int64',"divide_i64",0,line,0) + call dcl_uproc(parser,'/(x:int64,y:''1)=x',line) + call dcl_proc(parser,'**(int64,int64)->int64',"pow_i64",0,line,0) + call dcl_uproc(parser,'**(x:int64,y:''0)=1',line) + call dcl_uproc(parser,'**(x:int64,y:''1)=x',line) + call dcl_uproc(parser,'**(x:int64,y:''2)=x*x',line) + call dcl_proc(parser,'max(int64,int64)->int64',"max_i64",0,line,0) + call dcl_proc(parser,'min(int64,int64)->int64',"min_i64",0,line,0) + call dcl_proc(parser,'-(int64)->int64',"uminus_i64",0,line,0) + call dcl_proc(parser,'string(int64)->string',"string_i64",0,line,0) + call dcl_proc(parser,'sint(int64)->sint',"int_i64",0,line,0) + call dcl_proc(parser,'sreal(int64)->sreal',"real_i64",0,line,0) + call dcl_proc(parser,'real(int64)->real',"double_i64",0,line,0) + call dcl_uproc(parser,'int64(x:int64)=x',line) + call dcl_proc(parser,'abs(int64)->int64',"abs_i64",0,line,0) + call dcl_proc(parser,'~(int64)->int64',"bnot_i64",0,line,0) + call dcl_proc(parser,'&(int64,int64)->int64',"band_i64",0,line,0) + call dcl_proc(parser,'|(int64,int64)->int64',"bor_i64",0,line,0) + call dcl_proc(parser,'xor(int64,int64)->int64',"bxor_i64",0,line,0) + call dcl_proc(parser,'shift(int64,int64)->int64',& + "bshift_i64",0,line,0) + call dcl_proc(parser,'pdiff(int64,int64)->int64',"pdiff_i64",0,line,0) + call dcl_proc(parser,'sign(int64,int64)->int64',"sign_i64",0,line,0) + call dcl_proc(parser,'rem(int64,int64)->int64',"modulo_i64",0,line,0) + call dcl_proc(parser,'int8(int64)->int64',"i8_i64",0,line,0) + call dcl_proc(parser,'int16(int64)->int64',"i16_i64",0,line,0) + call dcl_proc(parser,'int32(int64)->int64',"i32_i64",0,line,0) + call dcl_proc(parser,'int(int64)->int',"long_i64",0,line,0) + call dcl_proc(parser,'lint(int64)->lint',"offset_i64",0,line,0) + +write(*,'(a)') '// sreal type' + call dcl_proc(parser,'PM__assign_var(&sreal,sreal)',& + "assign_r",0,line,0) + call dcl_proc(parser,'mod(sreal,sreal)->sreal',"mod_r",0,line,0) + call dcl_proc(parser,'==(sreal,sreal)->bool',"eq_r",0,line,0) + call dcl_proc(parser,'/=(sreal,sreal)->bool',"ne_r",0,line,0) + call dcl_proc(parser,'>=(sreal,sreal)->bool',"ge_r",0,line,0) + call dcl_proc(parser,'>(sreal,sreal)->bool',"gt_r",0,line,0) + call dcl_proc(parser,'+(sreal,sreal)->sreal',"add_r",0,line,0) + call dcl_proc(parser,'-(sreal,sreal)->sreal',"sub_r",0,line,0) + call dcl_proc(parser,'*(sreal,sreal)->sreal',"mult_r",0,line,0) + call dcl_proc(parser,'/(sreal,sreal)->sreal',"divide_r",0,line,0) + call dcl_proc(parser,'**(sreal,sreal)->sreal',"pow_r",0,line,0) + call dcl_proc(parser,'max(sreal,sreal)->sreal',"max_r",0,line,0) + call dcl_proc(parser,'min(sreal,sreal)->sreal',"min_r",0,line,0) + call dcl_proc(parser,'-(sreal)->sreal',"uminus_r",0,line,0) + call dcl_proc(parser,'string(sreal)->string',"string_r",0,line,0) + call dcl_proc(parser,'strunc(sreal)->sint',"int_r",0,line,0) + call dcl_proc(parser,'trunc(sreal)->int',"long_r",0,line,0) + call dcl_proc(parser,'ltrunc(sreal)->lint',"offset_r",0,line,0) + call dcl_proc(parser,'real(sreal)->real',"double_r",0,line,0) + call dcl_uproc(parser,'sreal(x:sreal)=x',line) + call dcl_proc(parser,'abs(sreal)->sreal',"abs_r",0,line,0) + call dcl_proc(parser,'acos(sreal)->sreal',"acos_r",0,line,0) + call dcl_proc(parser,'asin(sreal)->sreal',"asin_r",0,line,0) + call dcl_proc(parser,'atan(sreal)->sreal',"atan_r",0,line,0) + call dcl_proc(parser,'atan2(sreal,sreal)->sreal',"atan2_r",0,line,0) + call dcl_proc(parser,'cos(sreal)->sreal',"cos_r",0,line,0) + call dcl_proc(parser,'cosh(sreal)->sreal',"cosh_r",0,line,0) + call dcl_proc(parser,'exp(sreal)->sreal',"exp_r",0,line,0) + call dcl_proc(parser,'log(sreal)->sreal',"log_r",0,line,0) + call dcl_proc(parser,'log10(sreal)->sreal',"log10_r",0,line,0) + call dcl_proc(parser,'sin(sreal)->sreal',"sin_r",0,line,0) + call dcl_proc(parser,'sinh(sreal)->sreal',"sinh_r",0,line,0) + call dcl_proc(parser,'sqrt(sreal)->sreal',"sqrt_r",0,line,0) + call dcl_proc(parser,'tan(sreal)->sreal',"tan_r",0,line,0) + call dcl_proc(parser,'tanh(sreal)->sreal',"tanh_r",0,line,0) + call dcl_proc(parser,'floor(sreal)->sreal',"floor_r",0,line,0) + call dcl_proc(parser,'ceil(sreal)->sreal',"ceil_r",0,line,0) + call dcl_proc(parser,'rem(sreal,sreal)->sreal',"modulo_r",0,line,0) + call dcl_proc(parser,'sign(sreal,sreal)->sreal',"sign_r",0,line,0) + call dcl_proc(parser,'pdiff(sreal,sreal)->sreal',"pdiff_r",0,line,0) + call dcl_proc(parser,'lint(sreal)->lint',"offset_r",0,line,0) + call dcl_proc(parser,'scpx(sreal)->scpx',"complex_r",0,line,0) + call dcl_proc(parser,'_scpx2(sreal,sreal)->scpx',"complex2_r",0,line,0) + call dcl_uproc(parser,'scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y))',line) + +write(*,'(a)') '// real type' + call dcl_proc(parser,'PM__assign_var(&real,real)',& + "assign_d",0,line,0) + call dcl_proc(parser,'mod(real,real)->real',"mod_d",0,line,0) + call dcl_proc(parser,'==(real,real)->bool',"eq_d",0,line,0) + call dcl_proc(parser,'/=(real,real)->bool',"ne_d",0,line,0) + call dcl_proc(parser,'>=(real,real)->bool',"ge_d",0,line,0) + call dcl_proc(parser,'>(real,real)->bool',"gt_d",0,line,0) + call dcl_proc(parser,'+(real,real)->real',"add_d",0,line,0) + call dcl_proc(parser,'-(real,real)->real',"sub_d",0,line,0) + call dcl_proc(parser,'*(real,real)->real',"mult_d",0,line,0) + call dcl_proc(parser,'/(real,real)->real',"divide_d",0,line,0) + call dcl_proc(parser,'**(real,real)->real',"pow_d",0,line,0) + call dcl_proc(parser,'max(real,real)->real',"max_d",0,line,0) + call dcl_proc(parser,'min(real,real)->real',"min_d",0,line,0) + call dcl_proc(parser,'-(real)->real',"uminus_d",0,line,0) + call dcl_proc(parser,'string(real)->string',"string_d",0,line,0) + call dcl_proc(parser,'strunc(real)->sint',"int_d",0,line,0) + call dcl_proc(parser,'trunc(real)->int',"long_d",0,line,0) + call dcl_proc(parser,'ltrunc(real)->lint',"offset_d",0,line,0) + call dcl_proc(parser,'sreal(real)->sreal',"real_d",0,line,0) + call dcl_uproc(parser,'real(x:real)=x',line) + call dcl_proc(parser,'abs(real)->real',"abs_d",0,line,0) + call dcl_proc(parser,'acos(real)->real',"acos_d",0,line,0) + call dcl_proc(parser,'asin(real)->real',"asin_d",0,line,0) + call dcl_proc(parser,'atan(real)->real',"atan_d",0,line,0) + call dcl_proc(parser,'atan2(real,real)->real',& + "atan2_d",0,line,0) + call dcl_proc(parser,'cos(real)->real',"cos_d",0,line,0) + call dcl_proc(parser,'cosh(real)->real',"cosh_d",0,line,0) + call dcl_proc(parser,'exp(real)->real',"exp_d",0,line,0) + call dcl_proc(parser,'log(real)->real',"log_d",0,line,0) + call dcl_proc(parser,'log10(real)->real',"log10_d",0,line,0) + call dcl_proc(parser,'sin(real)->real',"sin_d",0,line,0) + call dcl_proc(parser,'sinh(real)->real',"sinh_d",0,line,0) + call dcl_proc(parser,'sqrt(real)->real',"sqrt_d",0,line,0) + call dcl_proc(parser,'tan(real)->real',"tan_d",0,line,0) + call dcl_proc(parser,'tanh(real)->real',"tanh_d",0,line,0) + call dcl_proc(parser,'floor(real)->real',"floor_d",0,line,0) + call dcl_proc(parser,'ceil(real)->real',"ceil_d",0,line,0) + call dcl_proc(parser,'rem(real,real)->real',"modulo_d",0,line,0) + call dcl_proc(parser,'sign(real,real)->real',"sign_d",0,line,0) + call dcl_proc(parser,'pdiff(real,real)->real',"pdiff_d",0,line,0) + call dcl_proc(parser,'lint(real)->lint',"offset_d",0,line,0) + call dcl_proc(parser,'cpx(real)->cpx',"complex_d",0,line,0) + call dcl_proc(parser,'_cpx2(real,real)->cpx',"complex2_d",0,line,0) + call dcl_uproc(parser,'cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y))',line) + +write(*,'(a)') '// scpx type' + call dcl_proc(parser,'PM__assign_var(&scpx,scpx)',& + "assign_c",0,line,0) + call dcl_proc(parser,'+(scpx,scpx)->scpx',"add_c",0,line,0) + call dcl_proc(parser,'-(scpx,scpx)->scpx',"sub_c",0,line,0) + call dcl_proc(parser,'*(scpx,scpx)->scpx',"mult_c",0,line,0) + call dcl_proc(parser,'/(scpx,scpx)->scpx',"divide_c",0,line,0) + call dcl_proc(parser,'**(scpx,sreal)->scpx',"rpow_c",0,line,0) + call dcl_proc(parser,'**(scpx,scpx)->scpx',"pow_c",0,line,0) + call dcl_proc(parser,'-(scpx)->scpx',"uminus_c",0,line,0) + call dcl_proc(parser,'==(scpx,scpx)->bool',"eq_c",0,line,0) + call dcl_proc(parser,'/=(scpx,scpx)->bool',"ne_c",0,line,0) + call dcl_proc(parser,'re(scpx)->sreal',"real_c",0,line,0) + call dcl_proc(parser,'abs(scpx)->scpx',"abs_c",0,line,0) + call dcl_proc(parser,'acos(scpx)->scpx',"acos_c",0,line,0) + call dcl_proc(parser,'asin(scpx)->scpx',"asin_c",0,line,0) + call dcl_proc(parser,'atan(scpx)->scpx',"atan_c",0,line,0) + call dcl_proc(parser,'atan2(scpx,scpx)->scpx',& + "atan2_c",0,line,0) + call dcl_proc(parser,'cos(scpx)->scpx',"cos_c",0,line,0) + call dcl_proc(parser,'cosh(scpx)->scpx',"cosh_c",0,line,0) + call dcl_proc(parser,'exp(scpx)->scpx',"exp_c",0,line,0) + call dcl_proc(parser,'log(scpx)->scpx',"log_c",0,line,0) + call dcl_proc(parser,'sin(scpx)->scpx',"sin_c",0,line,0) + call dcl_proc(parser,'sinh(scpx)->scpx',"sinh_c",0,line,0) + call dcl_proc(parser,'sqrt(scpx)->scpx',"sqrt_c",0,line,0) + call dcl_proc(parser,'tan(scpx)->scpx',"tan_c",0,line,0) + call dcl_proc(parser,'tanh(scpx)->scpx',"tanh_c",0,line,0) + call dcl_proc(parser,'im(scpx)->sreal',"imag_c",0,line,0) + call dcl_proc(parser,'conj(scpx)->scpx',"conj_c",0,line,0) + +write(*,'(a)') '// cpx type' + call dcl_proc(parser,'PM__assign_var(&cpx,cpx)',& + "assign_dc",0,line,0) + call dcl_proc(parser,'+(cpx,cpx)->cpx',"add_dc",0,line,0) + call dcl_proc(parser,'-(cpx,cpx)->cpx',"sub_dc",0,line,0) + call dcl_proc(parser,'*(cpx,cpx)->cpx',"mult_dc",0,line,0) + call dcl_proc(parser,'/(cpx,cpx)->cpx',"divide_dc",0,line,0) + call dcl_proc(parser,'**(cpx,real)->cpx',"dpow_dc",0,line,0) + call dcl_uproc(parser,'**(x:cpx,y:sreal)=x**real(y)',line) + call dcl_proc(parser,'**(cpx,cpx)->cpx',"pow_dc",0,line,0) + call dcl_proc(parser,'-(cpx)->cpx',"uminus_dc",0,line,0) + call dcl_proc(parser,'==(cpx,cpx)->bool',"eq_dc",0,line,0) + call dcl_proc(parser,'/=(cpx,cpx)->bool',"ne_dc",0,line,0) + call dcl_proc(parser,'re(cpx)->real',"real_dc",0,line,0) + call dcl_proc(parser,'abs(cpx)->cpx',"abs_dc",0,line,0) + call dcl_proc(parser,'acos(cpx)->cpx',"acos_dc",0,line,0) + call dcl_proc(parser,'asin(cpx)->cpx',"asin_dc",0,line,0) + call dcl_proc(parser,'atan(cpx)->cpx',"atan_dc",0,line,0) + call dcl_proc(parser,'atan2(cpx,cpx)->cpx',& + "atan2_dc",0,line,0) + call dcl_proc(parser,'cos(cpx)->cpx',"cos_dc",0,line,0) + call dcl_proc(parser,'cosh(cpx)->cpx',"cosh_dc",0,line,0) + call dcl_proc(parser,'exp(cpx)->cpx',"exp_dc",0,line,0) + call dcl_proc(parser,'log(cpx)->cpx',"log_dc",0,line,0) + call dcl_proc(parser,'sin(cpx)->cpx',"sin_dc",0,line,0) + call dcl_proc(parser,'sinh(cpx)->cpx',"sinh_dc",0,line,0) + call dcl_proc(parser,'sqrt(cpx)->cpx',"sqrt_dc",0,line,0) + call dcl_proc(parser,'tan(cpx)->cpx',"tan_dc",0,line,0) + call dcl_proc(parser,'tanh(cpx)->cpx',"tanh_dc",0,line,0) + call dcl_proc(parser,'im(cpx)->real',"imag_dc",0,line,0) + call dcl_proc(parser,'conj(cpx)->cpx',"conj_dc",0,line,0) + +write(*,'(a)') '// Cannot convert real to int (must use nint or trunc)' + call dcl_uproc(parser,& + 'sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => ''false',line) + call dcl_uproc(parser,& + 'int(x:any_real)=0 :test "Cannot convert real to integer" => ''false',line) + call dcl_uproc(parser,& + 'lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => ''false',line) + +write(*,'(a)') '// Some numeric conversions not hard-coded' + call dcl_uproc(parser,'cpx(x:real_num)=cpx(real(x))',line) + call dcl_uproc(parser,'scpx(x:real_num)=cpx(sreal(x))',line) + call dcl_uproc(parser,'string(x:any_int)=string(int64(x))',line) + call dcl_uproc(parser,& + 'string(x:any_cpx)='//& + ' string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x)',line) + call dcl_uproc(parser,'int(x:fix int)=x',line) + +write(*,'(a)') '// Abstract numeric types' + call dcl_type(parser,'any_int is sint,int,lint,int8,int16,int32,int64',& + line) + call dcl_type(parser,'any_real is sreal,real',line) + call dcl_type(parser,'any_cpx is scpx,cpx',line) + call dcl_type(parser,'int_num is any_int',line) + call dcl_type(parser,'real_num is int_num, any_real',line) + call dcl_type(parser,'cpx_num is real_num,any_cpx',line) + call dcl_type(parser,'num is cpx_num',line) + +write(*,'(a)') '// Numeric type conversion' + call dcl_uproc(parser,'convert(x,y)=x',line) + call dcl_uproc(parser,'convert(x:int_num,y:sint)=sint(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:int)=int(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:lint)=lint(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:int8)=int8(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:int16)=int16(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:int32)=int32(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:int64)=int64(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:sreal)=sreal(x)',line) + call dcl_uproc(parser,'convert(x:int_num,y:real)=real(x)',line) + call dcl_uproc(parser,'convert(x:real_num,y:cpx)=cpx(x)',line) + call dcl_uproc(parser,'convert(x:real_num,y:scpx)=scpx(x)',line) + + call dcl_uproc(parser,'as(x:int_num,y:)=sint(x)',line) + call dcl_uproc(parser,'as(x:int_num,y:)=int(x)',line) + call dcl_uproc(parser,'as(x:int_num,y:)=lint(x)',line) + call dcl_uproc(parser,'as(x:int_num,y:)=int8(x)',line) + call dcl_uproc(parser,'as(x:int_num,y:)=int16(x)',line) + call dcl_uproc(parser,'as(x:int_num,y:)=int32(x)',line) + call dcl_uproc(parser,'as(x:int_num,y:)=int64(x)',line) + call dcl_uproc(parser,'as(x:real_num,y:)=sreal(x)',line) + call dcl_uproc(parser,'as(x:real_num,y:)=real(x)',line) + call dcl_uproc(parser,'as(x:real_num,y:)=scpx(x)',line) + call dcl_uproc(parser,'as(x:real_num,y:)=cpx(x)',line) + +write(*,'(a)') '// Auto-conversion on assignment' + call dcl_uproc(parser,'PM__assign(&x:num,y:num) {_assign_element(&x,convert(y,x))}',line) + call dcl_uproc(parser,'PM__assign_var(&x:num,y:num) {PM__assign(&x,convert(y,x))}',line) + +write(*,'(a)') '// Mixed arithmatic' + call dcl_type(parser,'_to_sint is int',line) + call dcl_type(parser,'_to_lint is sint,int',line) + call dcl_type(parser,'_to_int8 is sint,int,lint',line) + call dcl_type(parser,'_to_int16 is sint,int,lint,int8',line) + call dcl_type(parser,'_to_int32 is sint,int,lint,int8,int16',line) + call dcl_type(parser,'_to_int64 is sint,int,lint,int8,int16,int32',line) + call dcl_type(parser,'_to_real is any_int',line) + call dcl_type(parser,'_to_sreal is any_int,real',line) + call dcl_type(parser,'_to_cpx is real_num',line) + call dcl_type(parser,'_to_scpx is real_num,cpx',line) + + call dcl_uproc(parser,'balance(x:sint,y:sint)=x,y',line) + call dcl_uproc(parser,'balance(x:int,y:int)=x,y',line) + call dcl_uproc(parser,'balance(x:lint,y:lint)=x,y',line) + call dcl_uproc(parser,'balance(x:int8,y:int8)=x,y',line) + call dcl_uproc(parser,'balance(x:int16,y:int16)=x,y',line) + call dcl_uproc(parser,'balance(x:int32,y:int32)=x,y',line) + call dcl_uproc(parser,'balance(x:int64,y:int64)=x,y',line) + call dcl_uproc(parser,'balance(x:sreal,y:sreal)=x,y',line) + call dcl_uproc(parser,'balance(x:real,y:real)=x,y',line) + call dcl_uproc(parser,'balance(x:scpx,y:scpx)=x,y',line) + call dcl_uproc(parser,'balance(x:cpx,y:cpx)=x,y',line) + + call dcl_uproc(parser,'balance(x:sint,y:_to_sint)=x,sint(y)',line) + call dcl_uproc(parser,'balance(x:lint,y:_to_lint)=x,lint(y)',line) + call dcl_uproc(parser,'balance(x:int8,y:_to_int8)=x,int8(y)',line) + call dcl_uproc(parser,'balance(x:int16,y:_to_int16)=x,int16(y)',line) + call dcl_uproc(parser,'balance(x:int32,y:_to_int32)=x,int32(y)',line) + call dcl_uproc(parser,'balance(x:int64,y:_to_int64)=x,int64(y)',line) + call dcl_uproc(parser,'balance(x:sreal,y:_to_sreal)=x,sreal(y)',line) + call dcl_uproc(parser,'balance(x:real,y:_to_real)=x,real(y)',line) + call dcl_uproc(parser,'balance(x:scpx,y:_to_scpx)=x,scpx(y)',line) + call dcl_uproc(parser,'balance(x:cpx,y:_to_cpx)=x,cpx(y)',line) + + call dcl_uproc(parser,'balance(x:_to_sint,y:sint)=sint(x),y',line) + call dcl_uproc(parser,'balance(x:_to_lint,y:lint)=lint(x),y',line) + call dcl_uproc(parser,'balance(x:_to_int8,y:int8)=int8(x),y',line) + call dcl_uproc(parser,'balance(x:_to_int16,y:int16)=int16(x),y',line) + call dcl_uproc(parser,'balance(x:_to_int32,y:int32)=int32(x),y',line) + call dcl_uproc(parser,'balance(x:_to_int64,y:int64)=int64(x),y',line) + call dcl_uproc(parser,'balance(x:_to_sreal,y:sreal)=sreal(x),y',line) + call dcl_uproc(parser,'balance(x:_to_real,y:real)=real(x),y',line) + call dcl_uproc(parser,'balance(x:_to_scpx,y:scpx)=scpx(x),y',line) + call dcl_uproc(parser,'balance(x:_to_cpx,y:cpx)=cpx(x),y',line) + + call dcl_uproc(parser,& + 'div(x:any_int,y:any_int)=if(sz=>r,-1-r)'//& + 'where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))'//& + 'where sz=sign(x,y)==x',line) + call dcl_uproc(parser,& + '_divz(x:any_int,y:any_int)=z '//& + '{var z,_=balance(x,y);if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y)}',line) + call dcl_uproc(parser,& + 'mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '==(x:num,y:num)=xx==yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '/=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '>=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '>(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '+(x:num,y:num)=xx+yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '-(x:num,y:num)=xx-yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '*(x:num,y:num)=xx*yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '/(x:num,y:num)=xx/yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '**(x:num,y:num)=xx**yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '&(x:num,y:num)=xx&yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '|(x:num,y:num)=xx|yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y)',line) + +write(*,'(a)') '// bool type' + call dcl_proc(parser,'PM__assign_var(&bool,bool)',& + "assign_l",0,line,0) + call dcl_proc(parser,'string(bool)->string',"string_l",0,line,0) + call dcl_proc(parser,'and(bool,bool)->bool',"and",0,line,0) + call dcl_proc(parser,'or(bool,bool)->bool',"or",0,line,0) + call dcl_proc(parser,'not(bool)->bool',"not",0,line,0) + call dcl_proc(parser,'==(bool,bool)->bool',"eq_l",0,line,0) + call dcl_proc(parser,'/=(bool,bool)->bool',"ne_l",0,line,0) + +!!$ ! Compile time bool values +!!$ call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'not(x:''true)=''false',line) +!!$ call dcl_uproc(parser,'not(x:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) + +write(*,'(a)') '// Masked types' + call dcl_type(parser,'masked(x) is '//& + 'rec {_val:x,_there:bool}',line) + call dcl_uproc(parser,'|(x:masked,y)=if(x._there=>x._val,y)'//& + 'check "Right operand of ""|"" does not match masked type on the left"=>same_type(x._val,y)',line) + call dcl_uproc(parser,& + 'masked(val,there:bool)=new masked {_val=val,_there=there}',line) + call dcl_uproc(parser,'defined(x:masked)=x._there',line) + call dcl_uproc(parser,'val(x:masked)=x._val '//& + 'check "masked value is undefined"=>x._there',line) + call dcl_uproc(parser,'get(&x,y:masked) {if y._there{x=y._val}}',line) + call dcl_uproc(parser,& + 'get(&x,y:masked(x)) {if y._there{x=y._val};return y._there}',line) + +write(*,'(a)') '// Polymorphic types' + call dcl_proc(parser,'get(x:*any,y:any)->=y',"as",0,line,0) + call dcl_proc(parser,'get(&x:any,y:*any)',"get_poly",0,line,& + proc_needs_type) + call dcl_proc(parser,'get(&x:any,y:*any)->bool',"get_poly2",0,line,& + proc_needs_type) + call dcl_proc(parser,'|(x:*any,y:any)->=y',"get_poly_or",0,line,& + proc_needs_type) + +write(*,'(a)') '// val function having null effect' + call dcl_uproc(parser,'val(x)=x',line) + + +write(*,'(a)') '// ********************************************' +WRITE(*,'(A)') '// TUPLES' +write(*,'(a)') '// ********************************************' + +write(*,'(a)') '// Tuple types' + call dcl_type(parser,& + 'tuple1d(t1) is rec {PM__d1:t1}',line) + call dcl_type(parser,& + 'tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2}',line) + call dcl_type(parser,& + 'tuple3d(t1,t2,t3) is'//& + ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3}',line) + call dcl_type(parser,& + 'tuple4d(t1,t2,t3,t4) is'//& + ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4}',line) + call dcl_type(parser,& + 'tuple5d(t1,t2,t3,t4,t5) is'//& + ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5}',line) + call dcl_type(parser,& + 'tuple6d(t1,t2,t3,t4,t5,t6) is'//& + ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6}',line) + call dcl_type(parser,& + 'tuple7d(t1,t2,t3,t4,t5,t6,t7) is'//& + ' rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7}',line) + + call dcl_type(parser,'tuple1d_of(t) is tuple1d(t)',line) + call dcl_type(parser,'tuple2d_of(t) is tuple2d(t,t)',line) + call dcl_type(parser,'tuple3d_of(t) is tuple3d(t,t,t)',line) + call dcl_type(parser,'tuple4d_of(t) is tuple4d(t,t,t,t)',line) + call dcl_type(parser,'tuple5d_of(t) is tuple5d(t,t,t,t,t)',line) + call dcl_type(parser,'tuple6d_of(t) is tuple6d(t,t,t,t,t,t)',line) + call dcl_type(parser,'tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t)',line) + + call dcl_type(parser,'tuple(t) is '//& + 'tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),'//& + 'tuple5d(t,t,t,t,t),tuple6d(t,t,t,t,t,t),'//& + 'tuple7d(t,t,t,t,t,t,t)',line) + + call dcl_uproc(parser,'tuple(x)=new tuple1d {PM__d1=x}',line) + call dcl_uproc(parser,'tuple(x,y)='//& + 'new tuple2d {PM__d1=x,PM__d2=y}',line) + call dcl_uproc(parser,'tuple(x,y,z)='//& + 'new tuple3d {PM__d1=x,PM__d2=y,PM__d3=z}',line) + call dcl_uproc(parser,'tuple(x,y,z,t)='//& + 'new tuple4d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t}',line) + call dcl_uproc(parser,'tuple(x,y,z,t,u)='//& + 'new tuple5d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u}',line) + call dcl_uproc(parser,'tuple(x,y,z,t,u,v)='//& + 'new tuple6d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v}',line) + call dcl_uproc(parser,'tuple(x,y,z,t,u,v,w)='//& + 'new tuple7d {PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w}',line) + + call dcl_uproc(parser,'get_dim(t:tuple1d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple2d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple3d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple4d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple5d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple6d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''1 or [''1])=t.1',line) + call dcl_uproc(parser,'get_dim(t:tuple2d,n:''2 or [''2])=t.2',line) + call dcl_uproc(parser,'get_dim(t:tuple3d,n:''2 or [''2])=t.2',line) + call dcl_uproc(parser,'get_dim(t:tuple4d,n:''2 or [''2])=t.2',line) + call dcl_uproc(parser,'get_dim(t:tuple5d,n:''2 or [''2])=t.2',line) + call dcl_uproc(parser,'get_dim(t:tuple6d,n:''2 or [''2])=t.2',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''2 or [''2])=t.2',line) + call dcl_uproc(parser,'get_dim(t:tuple3d,n:''3 or [''3])=t.3',line) + call dcl_uproc(parser,'get_dim(t:tuple4d,n:''3 or [''3])=t.3',line) + call dcl_uproc(parser,'get_dim(t:tuple5d,n:''3 or [''3])=t.3',line) + call dcl_uproc(parser,'get_dim(t:tuple6d,n:''3 or [''3])=t.3',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''3 or [''3])=t.3',line) + call dcl_uproc(parser,'get_dim(t:tuple4d,n:''4 or [''4])=t.4',line) + call dcl_uproc(parser,'get_dim(t:tuple5d,n:''4 or [''4])=t.4',line) + call dcl_uproc(parser,'get_dim(t:tuple6d,n:''4 or [''4])=t.4',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''4 or [''4])=t.4',line) + call dcl_uproc(parser,'get_dim(t:tuple5d,n:''5 or [''5])=t.5',line) + call dcl_uproc(parser,'get_dim(t:tuple6d,n:''5 or [''5])=t.5',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''5 or [''5])=t.5',line) + call dcl_uproc(parser,'get_dim(t:tuple6d,n:''6 or [''6])=t.6',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''6 or [''6])=t.6',line) + call dcl_uproc(parser,'get_dim(t:tuple7d,n:''7 or [''7])=t.7',line) +!!$ call dcl_uproc(parser,'get_dim(t:tuple,n:fix int)=t.1'//& +!!$ ' :test "tuple subscript out of range" => ''false',line) + + call dcl_uproc(parser,'indices(x:tuple1d)=[''1]',line) + call dcl_uproc(parser,'indices(x:tuple2d)=[''1,''2]',line) + call dcl_uproc(parser,'indices(x:tuple3d)=[''1,''2,''3]',line) + call dcl_uproc(parser,'indices(x:tuple4d)=[''1,''2,''3,''4]',line) + call dcl_uproc(parser,'indices(x:tuple5d)=[''1,''2,''3,''4,''5]',line) + call dcl_uproc(parser,'indices(x:tuple6d)=[''1,''2,''3,''4,''5,''6]',line) + call dcl_uproc(parser,'indices(x:tuple7d)=[''1,''2,''3,''4,''5,''6,''7]',line) + + call dcl_uproc(parser,'full_rank(x:tuple1d)=1',line) + call dcl_uproc(parser,'full_rank(x:tuple2d)=2',line) + call dcl_uproc(parser,'full_rank(x:tuple3d)=3',line) + call dcl_uproc(parser,'full_rank(x:tuple4d)=4',line) + call dcl_uproc(parser,'full_rank(x:tuple5d)=5',line) + call dcl_uproc(parser,'full_rank(x:tuple6d)=6',line) + call dcl_uproc(parser,'full_rank(x:tuple7d)=7',line) + + call dcl_uproc(parser,'rank(x:tuple)=full_rank(x)',line) + + call dcl_uproc(parser,'reduce(p:proc,x:tuple1d)=x.1',line) + call dcl_uproc(parser,'reduce(p:proc,x:tuple2d)='//& + 'p.(x.2,x.1)',line) + call dcl_uproc(parser,'reduce(p:proc,x:tuple3d)='//& + 'p.(p.(x.3,x.2),x.1)',line) + call dcl_uproc(parser,'reduce(p:proc,x:tuple4d)='//& + 'p.(p.(p.(x.4,x.3),x.2),x.1)',line) + call dcl_uproc(parser,'reduce(p:proc,x:tuple5d)='//& + 'p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1)',line) + call dcl_uproc(parser,'reduce(p:proc,x:tuple6d)='//& + 'p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1)',line) + call dcl_uproc(parser,'reduce(p:proc,x:tuple7d)='//& + 'p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1)',line) + + call dcl_uproc(parser,'map(p:proc,x:tuple1d)='//& + '[p.(x.1)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple2d)='//& + '[p.(x.1),p.(x.2)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple3d)='//& + '[p.(x.1),p.(x.2),p.(x.3)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple4d)='//& + '[p.(x.1),p.(x.2),p.(x.3),p.(x.4)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple5d)='//& + '[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple6d)='//& + '[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple7d)='//& + '[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)]',line) + + call dcl_uproc(parser,'map(p:proc,x:tuple,y:tuple)=error_type()'//& + ' :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d)='//& + '[p.(x.1,y.1)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d)='//& + '[p.(x.1,y.1),p.(x.2,y.2)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple3d,y:tuple3d)='//& + '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple4d,y:tuple4d)='//& + '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& + 'p.(x.4,y.4)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple5d,y:tuple5d)='//& + '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& + 'p.(x.4,y.4),p.(x.5,y.5)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple6d,y:tuple6d)='//& + '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& + 'p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple7d,y:tuple7d)='//& + '[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),'//& + 'p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)]',line) + + call dcl_uproc(parser,'map(p:proc,x:tuple,y:tuple,z:tuple)=error_type()'//& + ' :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)='//& + '[p.(x.1,y.1,z.1)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)='//& + '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)='//& + '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)='//& + '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& + 'p.(x.4,y.4,z.4)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)='//& + '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& + 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)='//& + '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& + 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)='//& + '[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),'//& + 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),'//& + 'p.(x.7,y.7,z.7)]',line) + + call dcl_uproc(parser,'map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type()'//& + ' :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)='//& + '[p.(w.1,x.1,y.1,z.1)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),'//& + 'p.(w.7,x.7,y.7,z.7)]',line) + + call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]'//& + 'where u1,v1=p.(x.1,y.1)',line) + call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]'//& + 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2)',line) + call dcl_uproc(parser,'map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]'//& + 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3)',line) + call dcl_uproc(parser,'map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]'//& + 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4)',line) + call dcl_uproc(parser,'map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]'//& + 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5)',line) + call dcl_uproc(parser,'map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]'//& + 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),'//& + 'u6,v6=p.(x.6,y.6)',line) + call dcl_uproc(parser,'map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]'//& + 'where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),'//& + 'u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7)',line) + + call dcl_uproc(parser,'map_const(p:proc,x:tuple1d,y)='//& + '[p.(x.1,y)]',line) + call dcl_uproc(parser,'map_const(p:proc,x:tuple2d,y)='//& + '[p.(x.1,y),p.(x.2,y)]',line) + call dcl_uproc(parser,'map_const(p:proc,x:tuple3d,y)='//& + '[p.(x.1,y),p.(x.2,y),p.(x.3,y)]',line) + call dcl_uproc(parser,'map_const(p:proc,x:tuple4d,y)='//& + '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& + 'p.(x.4,y)]',line) + call dcl_uproc(parser,'map_const(p:proc,x:tuple5d,y)='//& + '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& + 'p.(x.4,y),p.(x.5,y)]',line) + call dcl_uproc(parser,'map_const(p:proc,x:tuple6d,y)='//& + '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& + 'p.(x.4,y),p.(x.5,y),p.(x.6,y)]',line) + call dcl_uproc(parser,'map_const(p:proc,x:tuple7d,y)='//& + '[p.(x.1,y),p.(x.2,y),p.(x.3,y),'//& + 'p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)]',line) + + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple1d)='//& + 'q.(x.1)',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple2d)='//& + 'p.(q.(x.2),q.(x.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple3d)='//& + 'p.(p.(q.(x.3),q.(x.2)),q.(x.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple4d)='//& + 'p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple5d)='//& + 'p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),'//& + 'q.(x.2)),q.(x.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple6d)='//& + 'p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),'//& + 'q.(x.3)),q.(x.2)),q.(x.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple7d)='//& + 'p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),'//& + 'q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1))',line) + + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type()'//& + ' :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)='//& + 'q.(x.1,y.1)',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)='//& + 'p.(q.(x.2,y.2),q.(x.1,y.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)='//& + 'p.(p.(q.(x.3,y.3),q.(x.2,y.2)),'//& + 'q.(x.1,y.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)='//& + 'p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),'//& + 'q.(x.1,y.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)='//& + 'p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),'//& + 'q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)='//& + 'p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),'//& + 'q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)='//& + 'p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),'//& + 'q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1))',line) + + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type()'//& + ' :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)='//& + 'q.(x.1,y.1,z.1)',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)='//& + 'p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)='//& + 'p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),'//& + 'q.(x.1,y.1,z.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)='//& + 'p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),'//& + 'q.(x.1,y.1,z.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)='//& + 'p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),'//& + 'q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)='//& + 'p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),'//& + 'q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1))',line) + call dcl_uproc(parser,'map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)='//& + 'p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),'//& + 'q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1))',line) + + call dcl_uproc(parser,'apply(p:proc,x:tuple1d)='//& + 'p.(x.1)',line) + call dcl_uproc(parser,'apply(p:proc,x:tuple2d)='//& + 'p.(x.1,x.2)',line) + call dcl_uproc(parser,'apply(p:proc,x:tuple3d)='//& + 'p.(x.1,x.2,x.3)',line) + call dcl_uproc(parser,'apply(p:proc,x:tuple4d)='//& + 'p.(x.1,x.2,x.3,x.4)',line) + call dcl_uproc(parser,'apply(p:proc,x:tuple5d)='//& + 'p.(x.1,x.2,x.3,x.4,x.5)',line) + call dcl_uproc(parser,'apply(p:proc,x:tuple6d)='//& + 'p.(x.1,x.2,x.3,x.4,x.5,x.6)',line) + call dcl_uproc(parser,'apply(p:proc,x:tuple7d)='//& + 'p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7)',line) + + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple1d)='//& + 'p.(q.(x.1))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple2d)='//& + 'p.(q.(x.1),q.(x.2))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple3d)='//& + 'p.(q.(x.1),q.(x.2),q.(x.3))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple4d)='//& + 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple5d)='//& + 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),'//& + 'q.(x.5))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple6d)='//& + 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),'//& + 'q.(x.5),q.(x.6))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple7d)='//& + 'p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),'//& + 'q.(x.5),q.(x.6),q.(x.7))',line) + + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type()'//& + ':test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)='//& + 'p.(q.(x.1,y.1))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)='//& + 'p.(q.(x.1,y.1),q.(x.2,y.2))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)='//& + 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)='//& + 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)='//& + 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),'//& + 'q.(x.5,y.5))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)='//& + 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),'//& + 'q.(x.5,y.5),q.(x.6,y.6))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)='//& + 'p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),'//& + 'q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7))',line) + + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)='//& + 'error_type() :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)='//& + 'p.(q.(x.1,y.1,z.1))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)='//& + 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)='//& + 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)='//& + 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)='//& + 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),'//& + 'q.(x.5,y.5,z.5))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)='//& + 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),'//& + 'q.(x.5,y.5,z.5),q.(x.6,y.6,z.6))',line) + call dcl_uproc(parser,'map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)='//& + 'p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),'//& + 'q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7))',line) + + + call dcl_uproc(parser,'scan(p:proc,x:tuple1d)=x.1',line) + call dcl_uproc(parser,'scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)]',line) + call dcl_uproc(parser,'scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)]'//& + ' where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)]'//& + ' where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)]'//& + ' where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)]'//& + ' where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) '//& + ' where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)]'//& + ' where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) '//& + ' where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) + + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple1d,x0)=x0',line) + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1]',line) + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)]',line) + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)]'//& + ' where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)]'//& + ' where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)]'//& + ' where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2)',line) + call dcl_uproc(parser,'pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)]'//& + ' where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) '//& + ' where x2=p.(x.1,x.2)',line) + + call dcl_type(parser,'empty_head is unique',line) + call dcl_uproc(parser,'head(x:null)=empty_head',line) + call dcl_uproc(parser,'head(x:tuple)=x.1',line) + + call dcl_uproc(parser,'tail(x:null)=null',line) + call dcl_uproc(parser,'tail(x:tuple1d)=null',line) + call dcl_uproc(parser,'tail(x:tuple2d)=[x.2]',line) + call dcl_uproc(parser,'tail(x:tuple3d)=[x.2,x.3]',line) + call dcl_uproc(parser,'tail(x:tuple4d)=[x.2,x.3,x.4]',line) + call dcl_uproc(parser,'tail(x:tuple5d)=[x.2,x.3,x.4,x.5]',line) + call dcl_uproc(parser,'tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6]',line) + call dcl_uproc(parser,'tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7]',line) + + call dcl_uproc(parser,'prepend(y,x:null)=[y]',line) + call dcl_uproc(parser,'prepend(y,x:tuple1d)=[y,x.1]',line) + call dcl_uproc(parser,'prepend(y,x:tuple2d)=[y,x.1,x.2]',line) + call dcl_uproc(parser,'prepend(y,x:tuple3d)=[y,x.1,x.2,x.3]',line) + call dcl_uproc(parser,'prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4]',line) + call dcl_uproc(parser,'prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5]',line) + call dcl_uproc(parser,'prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6]',line) + call dcl_uproc(parser,& + 'prepend(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => ''false',line) + + call dcl_uproc(parser,'append(x:null,y)=[y]',line) + call dcl_uproc(parser,'append(x:tuple1d,y)=[x.1,y]',line) + call dcl_uproc(parser,'append(x:tuple2d,y)=[x.1,x.2,y]',line) + call dcl_uproc(parser,'append(x:tuple3d,y)=[x.1,x.2,x.3,y]',line) + call dcl_uproc(parser,'append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y]',line) + call dcl_uproc(parser,'append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y]',line) + call dcl_uproc(parser,'append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y]',line) + call dcl_uproc(parser,& + 'append(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => ''false',line) + + call dcl_uproc(parser,'elems(x:tuple1d)=x.1',line) + call dcl_uproc(parser,'elems(x:tuple2d)=x.1,x.2',line) + call dcl_uproc(parser,'elems(x:tuple3d)=x.1,x.2,x,3',line) + call dcl_uproc(parser,'elems(x:tuple4d)=x.1,x.2,x.3,x.4',line) + call dcl_uproc(parser,'elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5',line) + call dcl_uproc(parser,'elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6',line) + call dcl_uproc(parser,'elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7',line) + + call dcl_uproc(parser,'replace(x:tuple1d,y:''1,z)=[z]',line) + call dcl_uproc(parser,'replace(x:tuple2d,y:''1,z)=[z,x.2]',line) + call dcl_uproc(parser,'replace(x:tuple3d,y:''1,z)=[z,x.2,x.3]',line) + call dcl_uproc(parser,'replace(x:tuple4d,y:''1,z)=[z,x.2,x.3,x.4]',line) + call dcl_uproc(parser,'replace(x:tuple5d,y:''1,z)=[z,x.2,x.3,x.4,x.5]',line) + call dcl_uproc(parser,'replace(x:tuple6d,y:''1,z)=[z,x.2,x.3,x.4,x.5,x.6]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''1,z)=[z,x.2,x.3,x.4,x.5,x.6,x.7]',line) + call dcl_uproc(parser,'replace(x:tuple2d,y:''2,z)=[x.1,z]',line) + call dcl_uproc(parser,'replace(x:tuple3d,y:''2,z)=[x.1,z,x.3]',line) + call dcl_uproc(parser,'replace(x:tuple4d,y:''2,z)=[x.1,z,x.3,x.4]',line) + call dcl_uproc(parser,'replace(x:tuple5d,y:''2,z)=[x.1,z,x.3,x.4,x.5]',line) + call dcl_uproc(parser,'replace(x:tuple6d,y:''2,z)=[x.1,z,x.3,x.4,x.5,x.6]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''2,z)=[x.1,z,x.3,x.4,x.5,x.6,x.7]',line) + call dcl_uproc(parser,'replace(x:tuple3d,y:''3,z)=[x.1,x.2,z]',line) + call dcl_uproc(parser,'replace(x:tuple4d,y:''3,z)=[x.1,x.2,z,x.4]',line) + call dcl_uproc(parser,'replace(x:tuple5d,y:''3,z)=[x.1,x.2,z,x.4,x.5]',line) + call dcl_uproc(parser,'replace(x:tuple6d,y:''3,z)=[x.1,x.2,z,x.4,x.5,x.6]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''3,z)=[x.1,x.2,z,x.4,x.5,x.6,x.7]',line) + call dcl_uproc(parser,'replace(x:tuple4d,y:''4,z)=[x.1,x.2,x.3,z]',line) + call dcl_uproc(parser,'replace(x:tuple5d,y:''4,z)=[x.1,x.2,x.3,z,x.5]',line) + call dcl_uproc(parser,'replace(x:tuple6d,y:''4,z)=[x.1,x.2,x.3,z,x.5,x.6]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''4,z)=[x.1,x.2,x.3,z,x.5,x.6,x.7]',line) + call dcl_uproc(parser,'replace(x:tuple5d,y:''5,z)=[x.1,x.2,x.3,x.4,z]',line) + call dcl_uproc(parser,'replace(x:tuple6d,y:''5,z)=[x.1,x.2,x.3,x.4,z,x.6]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''5,z)=[x.1,x.2,x.3,x.4,z,x.6,x.7]',line) + call dcl_uproc(parser,'replace(x:tuple6d,y:''6,z)=[x.1,x.2,x.3,x.4,x.5,z]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''6,z)=[x.1,x.2,x.3,x.4,x.5,z,x.7]',line) + call dcl_uproc(parser,'replace(x:tuple7d,y:''7,z)=[x.1,x.2,x.3,x.4,x.5,x.6,z]',line) + + call dcl_uproc(parser,'spread(x,y:tuple1d or ''1)=[x]',line) + call dcl_uproc(parser,'spread(x,y:tuple2d or ''2)=[x,x]',line) + call dcl_uproc(parser,'spread(x,y:tuple3d or ''3)=[x,x,x]',line) + call dcl_uproc(parser,'spread(x,y:tuple4d or ''4)=[x,x,x,x]',line) + call dcl_uproc(parser,'spread(x,y:tuple5d or ''5)=[x,x,x,x,x]',line) + call dcl_uproc(parser,'spread(x,y:tuple6d or ''6)=[x,x,x,x,x,x]',line) + call dcl_uproc(parser,'spread(x,y:tuple7d or ''7)=[x,x,x,x,x,x,x]',line) + + call dcl_uproc(parser,'+(x:tuple(num),y:tuple(num))=map($+,x,y)',line) + call dcl_uproc(parser,'-(x:tuple(num),y:tuple(num))=map($-,x,y)',line) + call dcl_uproc(parser,'*(x:tuple(num),y:tuple(num))=map($*,x,y)',line) + call dcl_uproc(parser,'/(x:tuple(num),y:tuple(num))=map($/,x,y)',line) + call dcl_uproc(parser,'**(x:tuple(num),y:tuple(num))=map($**,x,y)',line) + call dcl_uproc(parser,'mod(x:tuple(num),y:tuple(num))=map($mod,x,y)',line) + + call dcl_uproc(parser,'+(x:tuple(num),y:num)=map_const($+,x,y)',line) + call dcl_uproc(parser,'-(x:tuple(num),y:num)=map_const($-,x,y)',line) + call dcl_uproc(parser,'*(x:tuple(num),y:num)=map_const($*,x,y)',line) + call dcl_uproc(parser,'/(x:tuple(num),y:num)=map_const($/,x,y)',line) + call dcl_uproc(parser,'**(x:tuple(num),y:num)=map_const($**,x,y)',line) + call dcl_uproc(parser,'mod(x:tuple(num),y:num)=map_const($mod,x,y)',line) + + call dcl_uproc(parser,'max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y)',line) + call dcl_uproc(parser,'min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y)',line) + call dcl_uproc(parser,'max(x:tuple(real_num))=reduce($max,x)',line) + call dcl_uproc(parser,'min(x:tuple(real_num))=reduce($min,x)',line) + call dcl_uproc(parser,'sum(x:tuple(num))=reduce($+,x)',line) + call dcl_uproc(parser,'prod(x:tuple(num))=reduce($*,x)',line) + + call dcl_uproc(parser,'sint(x:tuple(num))=map($sint,x)',line) + call dcl_uproc(parser,'int(x:tuple(num))=map($int,x)',line) + call dcl_uproc(parser,'sreal(x:tuple(num))=map($sreal,x)',line) + call dcl_uproc(parser,'real(x:tuple(num))=map($real,x)',line) + + call dcl_uproc(parser,'string(x:tuple1d)="[ "++x.1++" ]"',line) + call dcl_uproc(parser,'string(x:tuple2d)="[ "++x.1++", "++x.2++" ]"',line) + call dcl_uproc(parser,'string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]"',line) + call dcl_uproc(parser,'string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]"',line) + call dcl_uproc(parser,& + 'string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]"',line) + call dcl_uproc(parser,'string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++'//& + '", "++x.6++" ]"',line) + call dcl_uproc(parser,'string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++'//& + '", "++x.6++", "++x.7++" ]"',line) + +write(*,'(a)') '// *****************************************************' +WRITE(*,'(A)') '// RANGES AND SEQUENCES' +write(*,'(a)') '// *****************************************************' + +write(*,'(a)') '// Not in operator' + call dcl_uproc(parser,'notin(x,y)=not(x in y)',line) + +write(*,'(a)') '// not inc operator' + call dcl_uproc(parser,'notinc(x,y)=not(x inc y)',line) + +write(*,'(a)') '// Treat null as empty sequence in some cases' + call dcl_uproc(parser,'in(x,y:null)=''false',line) + call dcl_uproc(parser,'in(x:null,y:null)=''true',line) + +write(*,'(a)') '// Range base type (might later expand to interface)' + call dcl_type(parser,'range_base is real_num',line) + +write(*,'(a)') '// Single point sequence' + call dcl_type(parser,'single_point(t:range_base) is rec {_t:t}',line) + call dcl_uproc(parser,'single_point(x)=new single_point {_t=x}',line) + call dcl_uproc(parser,'low(x:single_point)=x._t',line) + call dcl_uproc(parser,'high(x:single_point)=x._t',line) + call dcl_uproc(parser,'step(x:single_point)=x._t',line) + call dcl_uproc(parser,'width(x:single_point)=''1',line) + call dcl_uproc(parser,'norm(x:single_point)=x',line) + call dcl_uproc(parser,'#(x:single_point)=shape([''0..''0])',line) + call dcl_uproc(parser,'_shp(x:single_point)=''0..''0',line) + call dcl_uproc(parser,'dims(x:single_point)=[''1]',line) + call dcl_uproc(parser,'size(x:single_point)=''1',line) + call dcl_uproc(parser,'+(x:single_point,y:range_base)=new single_point {_t=x._t+y}',line) + call dcl_uproc(parser,'-(x:single_point,y:range_base)=new single_point {_t=x._t-y}',line) + call dcl_uproc(parser,'_arb(x:single_point)=x._t',line) + call dcl_uproc(parser,'in(x:range_base,y:single_point)=x==y._t',line) + call dcl_uproc(parser,' inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t',line) +!write(*,'(a)') '// call dcl_uproc(parser,' inc(x:seq,y:single_point)=y._t in x',line)' + call dcl_uproc(parser,'convert(x:single_point,y:range_base)=single_point(convert(x._t,y))',line) + call dcl_uproc(parser,'sint(x:single_point)=single_point(sint(x._t))',line) + call dcl_uproc(parser,'int(x:single_point)=single_point(int(x._t))',line) + call dcl_uproc(parser,'sreal(x:single_point)=single_point(sreal(x._t))',line) + call dcl_uproc(parser,'real(x:single_point)=single_point(real(x._t))',line) + call dcl_uproc(parser,'#(x:single_point,y:index)=''0',line) + call dcl_uproc(parser,'#(x:single_point,y:grid_slice_dim)=''0..''0',line) + call dcl_uproc(parser,'#(x:single_point,y:single_point)=''0..''0',line) + call dcl_uproc(parser,'#(x:grid_slice_dim,y:single_point)=single_point(xx) where xx=x#y._t',line) + call dcl_uproc(parser,'overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1)',line) + call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1)',line) + call dcl_uproc(parser,'overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1)',line) + call dcl_uproc(parser,'overlap(x:single_point(any_int),y:single_point(any_int))=overlap(x,y),overlap(y,x)',line) + call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:single_point(any_int))=overlap(x,y),overlap(y,x)',line) + call dcl_uproc(parser,'overlap(x:single_point(any_int),y:grid_slice_dim)=overlap(x,y),overlap(y,x)',line) + call dcl_uproc(parser,'intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1)',line) + call dcl_uproc(parser,'intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1)',line) + call dcl_uproc(parser,'intersect(x:single_point(any_int),y:single_point(any_int))='//& + 'x._t..if(x._t==y._t=>x._t,x._t-1)',line) + + call dcl_uproc(parser,'element(x:single_point,y:index)=x._t',line) + call dcl_uproc(parser,'element(x:single_point,y:subs)=x._t..x._t',line) + call dcl_uproc(parser,'element(x,y:single_point)=element(x,y._t)',line) + call dcl_uproc(parser,'string(x:single_point)=string("single "++x._t)',line) + +write(*,'(a)') '// Range types' + call dcl_type(parser,'range(t:range_base) is rec {_lo:t,_hi:t,_n:t}',line) + call dcl_uproc(parser,'..(x:range_base,y:range_base)='//& + 'new range {_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) +!!$ call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& +!!$ 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) + call dcl_uproc(parser,'low(x:range)=x._lo',line) + call dcl_uproc(parser,'high(x:range)=x._hi',line) + call dcl_uproc(parser,'step(x:range)=convert(1,x._lo)',line) + call dcl_uproc(parser,'width(x:range)=''1',line) + call dcl_uproc(parser,'norm(x:range)=x',line) + call dcl_uproc(parser,'#(x:range(int))=shape([0..x._n-1])',line) + call dcl_uproc(parser,'dims(x:range(int))=[x._n]',line) + call dcl_uproc(parser,& + 'size(x:range(int))=x._n',line) + call dcl_uproc(parser,'+(x:range,y:range_base)=new range {_lo=x._lo+y,_hi=x._hi+y,_n=x._n}',line) + call dcl_uproc(parser,'-(x:range,y:range_base)=new range {_lo=x._lo-y,_hi=x._hi-y,_n=x._n}',line) + call dcl_uproc(parser,& + '_arb(x:range)=low(x)',line) + call dcl_uproc(parser,& + 'in(x:range_base,y:range())=x>=y._lo and x<=y._hi',line) + call dcl_uproc(parser,'convert(x:range,y:range_base)='//& + 'new range {_lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n}',line) + call dcl_uproc(parser,& + 'sint(x:range)=new range {_lo=sint(x._lo),_hi=sint(x._hi),_n=x._n}',line) + call dcl_uproc(parser,& + 'int(x:range)=new range {_lo=int(x._lo),_hi=int(x._hi),_n=x._n}',line) + call dcl_uproc(parser,& + 'sreal(x:range)=new range {_lo=sreal(x._lo),_hi=sreal(x._hi)}',line) + call dcl_uproc(parser,'real(x:range)='//& + 'new range {_lo=real(x._lo),_hi=real(x._hi),_n=x._n}',line) + call dcl_uproc(parser,& + ' inc(x:range,y:seq())='//& + ' low(y)>=x._lo and high(y)<=x._hi',line) + call dcl_uproc(parser,& + 'element(x:range(any_int),y:int)=x._lo+convert(y,x._lo)',line) + call dcl_uproc(parser,& + 'element(x:range(any_int),y:range(int))='//& + 'element(x,y._lo)..element(x,y._hi)',line) + call dcl_uproc(parser,& + 'element(x:range(any_int),y:seq(int))='//& + 'element(x,y._lo)..element(x,y._hi) by y._st',line) + call dcl_uproc(parser,& + 'element(x:range(any_int),y:null)=x',line) + call dcl_uproc(parser,& + 'element(x:range(any_int),y:grid_dim)=y+x._lo',line) + call dcl_uproc(parser,& + '#(y:range(any_int),x:int)=int(x-y._lo)',line) + call dcl_uproc(parser,'#(y:range(any_int),x:range(int))='//& + 'int(x._lo-y._lo)..int(x._hi-y._lo)',line) + call dcl_uproc(parser,'#(y:range(any_int),x:seq(int))='//& + '_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st)',line) + call dcl_uproc(parser,& + '#(y:range(any_int),x:range_below(int))='//& + '0..int(x._t-y._lo)',line) + call dcl_uproc(parser,& + '#(y:range(any_int),x:range_above(int))='//& + 'int(x._t-y._lo)..size(y)-1',line) + call dcl_uproc(parser,'#(y:range(any_int),x:strided_range_below(int))='//& + '_intseq(0,int(x._t-y._lo),x._st)',line) + call dcl_uproc(parser,'#(y:range(any_int),x:strided_range_above(int))='//& + '_intseq(int(x._t-y._lo),size(y)-1,int(x._st))',line) + call dcl_uproc(parser,'#(y:range(any_int),x:stride(int))='//& + '_intseq(0,size(y),int(x._st))',line) + call dcl_uproc(parser,'#(y:range(any_int),x:null)=0..size(y)',line) + call dcl_uproc(parser,'intersect(x:range(any_int),y:range(any_int))='//& + 'max(y._lo,x._lo)..min(y._hi,x._hi)',line) + call dcl_uproc(parser,'overlap(x:range(any_int),y:range(any_int))='//& + 'max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo',line) + + call dcl_uproc(parser,'expand(x:range,y:range)='//& + 'x._lo+y._lo..x._hi+y._hi',line) + call dcl_uproc(parser,'contract(x:range,y:range)='//& + 'x._lo-y._lo..x._hi-y._hi',line) + call dcl_uproc(parser,'empty(x:range)=new range {_lo=x._hi,_hi=x._lo,_n=0}',line) + call dcl_uproc(parser,'string(x:range)=string(x._lo)++".."++(x._hi)',line) + +write(*,'(a)') '// Cyclic range types (limited functionality and not part of grid)' + call dcl_type(parser,'cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int}',line) + call dcl_uproc(parser,'cyclic_range(x:int,y:int,w:int)='//& + 'new cyclic_range {_lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,'low(x:cyclic_range)=x._lo',line) + call dcl_uproc(parser,'high(x:cyclic_range)=x._hi',line) + call dcl_uproc(parser,'size(x:cyclic_range)=x._n',line) + call dcl_uproc(parser,'element(x:cyclic_range,y:int)=(x._lo + y) mod x._w',line) + call dcl_uproc(parser,'string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")"',line) + +write(*,'(a)') '// Strided range types' + call dcl_type(parser,& + 'strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int}',line) + call dcl_type(parser,& + '_any_seq(t:range_base):iterable is strided_range(t), ... ',line) + call dcl_type(parser,& + '_any_seq(t:any_int) is ..., range(t)',line) + call dcl_type(parser,'seq(t:range_base) is _any_seq(t)',line) + call dcl_uproc(parser,'_seq(lo,hi,st)=new strided_range {_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}'//& + 'check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st)))',line) + call dcl_uproc(parser,'by(x:range(int),y:range_base)=_seq(lo,hi,st)'//& + ' where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y)',line) + call dcl_uproc(parser,'by(x:seq,y:range_base)=_seq(lo,hi,st) where'//& + ' lo=convert(x._lo,st),hi=convert(x._hi,st)'//& + ' where st=x._st*y',line) + call dcl_uproc(parser,'_intseq(x:int,y:int,st:int)='//& + ' new strided_range {_lo=x,_hi=x+n*s,_st=s,_n=n}'//& + ' where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st)',line) + call dcl_uproc(parser,'low(x:strided_range)=x._lo',line) + call dcl_uproc(parser,'high(x:strided_range)=x._hi',line) + call dcl_uproc(parser,'step(x:strided_range)=x._st',line) + call dcl_uproc(parser,'size(x:strided_range)=x._n',line) + call dcl_uproc(parser,'width(x:strided_range)=''1',line) + call dcl_uproc(parser,'norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)'//& + 'where hi=lo+(x._n-1)*x._st where lo=x._lo',line) + call dcl_uproc(parser,'align(x:seq)=''0',line) + call dcl_uproc(parser,'#(x:strided_range)=shape([0..x._n-1])',line) + call dcl_uproc(parser,'dims(x:strided_range)=[x._n]',line) + call dcl_uproc(parser,'+(x:strided_range,y:range_base)='//& + 'new strided_range {_lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n}',line) + call dcl_uproc(parser,'-(x:strided_range,y:range_base)='//& + 'new strided_range {_lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n}',line) + call dcl_uproc(parser,'_arb(x:seq)=x._lo',line) + call dcl_uproc(parser,'convert(x:strided_range,y:range_base)='//& + 'new strided_range {_lo=convert(x._lo,y),_hi=convert(x._hi,y),'//& + '_st=convert(x._st,y),_n=x._n}',line) + call dcl_uproc(parser,'sint(x:strided_range)='//& + 'new strided_range {_lo=sint(x._lo),_hi=sint(x._hi),'//& + '_st=sint(x._st),_n=x._n}',line) + call dcl_uproc(parser,'int(x:strided_range)='//& + 'new strided_range {_lo=int(x._lo),_hi=int(x._hi),'//& + '_st=int(x._st),_n=x._n}',line) + call dcl_uproc(parser,'sreal(x:strided_range)='//& + 'new strided_range {_lo=sreal(x._lo),_hi=sreal(x._hi),'//& + '_st=sreal(x._st),_n=x._n}',line) + call dcl_uproc(parser,'real(x:strided_range)='//& + 'new strided_range {_lo=real(x._lo),_hi=real(x._hi),'//& + '_st=real(x._st),_n=x._n}',line) + call dcl_uproc(parser,& + 'in(x:int,y:strided_range(int))='//& + 'y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0',line) + call dcl_uproc(parser,& + 'inc(x:strided_range(int),y:strided_range(int))='//& + 'y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x)',line) + call dcl_uproc(parser,& + 'inc(x:strided_range(int),y:range(int) or single_point(int))='//& + 'x inc low(y)..high(y) by 1',line) + call dcl_uproc(parser,& + '#(y:seq,x:range_base)=int((x-y._lo)/y._st)',line) + call dcl_uproc(parser,& + '#(y:seq,x:range)=y#x._lo..y#x._hi',line) + call dcl_uproc(parser,& + '#(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) '//& + ' where lo=y#x._lo,hi=y#x._hi',line) + call dcl_uproc(parser,& + '#(y:seq,x:range_below)=0..y#x._t',line) + call dcl_uproc(parser,& + '#(y:seq,x:range_above)=y#x._t..size(y)-1',line) + call dcl_uproc(parser,& + '#(y:seq,x:strided_range_below)='//& + '_intseq(0,y#x._t,int((x._st+y._st/2)/y._st))',line) + call dcl_uproc(parser,& + '#(y:seq,x:strided_range_above)='//& + '_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st))',line) + call dcl_uproc(parser,& + '#(y:seq,x:stride)=_intseq(0,size(y),int((x._st+y._st/2)/y._st))',line) + call dcl_uproc(parser,& + '#(y:seq,x:null)=0..size(y)-1',line) + call dcl_uproc(parser,'string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st',line) + + call dcl_uproc(parser,& + 'element(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st',line) + call dcl_uproc(parser,& + 'element(x:strided_range,y:range(int))='//& + '_seq(element(x,y._lo),element(x,y._hi),x._st)',line) + call dcl_uproc(parser,& + 'element(x:strided_range,y:strided_range(int))='//& + '_seq(element(x,y._lo),element(x,y._hi),'//& + 'convert(st*y._st,st)) where st=x._st',line) + call dcl_uproc(parser,& + 'element(x:strided_range,y:null)=x',line) + + call dcl_uproc(parser,& + 'overlap(x:strided_range(any_int),y:range(any_int))='//& + ' max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st)',line) + call dcl_uproc(parser,& + 'overlap(x:range(any_int),y:strided_range(any_int))='//& + 'max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo',line) !!! WRONG + call dcl_uproc(parser,& + 'intersect(x:strided_range(any_int),y:range(any_int))='//& + 'x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st'//& + ' where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st',line) + call dcl_uproc(parser,& + 'intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x)',line) + + call dcl_proc(parser,& + '_intersect_seq(int,int,int,int,int,int,int,int)->int,int,int,int',& + "intersect_seq",0,line,0) + call dcl_uproc(parser,'intersect(x:strided_range(any_int),y:strided_range(any_int))='//& + 'new strided_range {_lo=lo,_hi=hi,_st=st,_n=n}'//& + 'where lo,hi,st,n='//& + '_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& + 'int(y._lo),int(y._hi),int(y._st),int(y._n))',line) + call dcl_uproc(parser,'overlap(x:strided_range(any_int),y:strided_range(any_int))='//& + 'new strided_range {_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n}'//& + ' where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& + ' int(y._lo),int(y._hi),int(y._st),int(y._n))',line) + call dcl_uproc(parser,'empty(x:strided_range(any_int))='//& + 'new strided_range {_lo=x._hi,_hi=x._lo,_st=x._st,_n=0}',line) + +write(*,'(a)') '// Block sequence' + call dcl_type(parser,& + 'block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int}',line) + call dcl_uproc(parser,'block_seq(lo:int,hi:int,st:int,b:int,align:int){'//& + 'test "Block sequence width must be non-negative: "++b=>b>=0;'//& + 'test "Block sequence width must be less than step: "++b++">="++st=>b<=st;'//& + 'test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1)',line) + call dcl_uproc(parser,'last_block(x:block_seq)=low..min(low+x._b,x._hi) '//& + 'where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st',line) + call dcl_uproc(parser,'middle_blocks(x:block_seq)=new block_seq {'//& + '_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}'//& + 'where nb=(x._hi-low+x._st-x._b+1)/x._st '//& + 'where low=if(x._align==0=>x._lo,x._lo-x._align+x._st)',line) + call dcl_uproc(parser,& + 'string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align',& + line) + call dcl_uproc(parser,'low(x:block_seq)=x._lo',line) + call dcl_uproc(parser,'high(x:block_seq)=x._hi',line) + call dcl_uproc(parser,'step(x:block_seq)=x._st',line) + call dcl_uproc(parser,'width(x:block_seq)=x._b',line) + call dcl_uproc(parser,'norm(x:block_seq)=x',line) + call dcl_uproc(parser,'align(x:block_seq)=x._align',line) + call dcl_uproc(parser,'#(x:block_seq)=shape([0..x._n-1])',line) + call dcl_uproc(parser,'dims(x:block_seq)=x._n',line) + call dcl_uproc(parser,'size(x:block_seq)=x._n',line) + call dcl_uproc(parser,'+(x:block_seq,y:int)='//& + 'new block_seq {_lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align}',line) + call dcl_uproc(parser,'-(x:block_seq,y:int)='//& + 'new block_seq {_lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align}',line) + call dcl_uproc(parser,'_arb(x:block_seq)=x._lo',line) + call dcl_uproc(parser,'in(x:int,y:block_seq)='//& + 'x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st;'//& + ' if hi-nbhi>=x._b:hi=nbhi+x._b-1;'//& + ' align=base-(base/x._st)*x._st '//& + ' where base=lo-oldbase;'//& + ' return block_seq(lo,hi,x._st,x._b,align)'//& + '}',line) + call dcl_uproc(parser,'intersect(x:range(any_int),y:block_seq)=intersect(y,x)',line) + call dcl_uproc(parser,'overlap(x:range(any_int),y:block_seq) {'//& + 'z=intersect(y,x);'//& + 'return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align)}',line) + call dcl_uproc(parser,'overlap(x:block_seq,y:range(any_int)) {'//& + 'z=intersect(x,y);'//& + 'return start..start+size(z)-1 where start=z#z._lo}',line) + call dcl_uproc(parser,'overlap(x:block_seq,y:range(any_int)) {'//& + 'z=intersect(x,y);'//& + 'return start..start+size(z)-1,'//& + ' block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align)'//& + ' where start=z#z._lo}',line) + call dcl_uproc(parser,'overlap(x:range(any_int),y:block_seq)=xx,yy'//& + ' where yy,xx=overlap(y,x)',line) + call dcl_uproc(parser,'empty(x:block_seq)=block_seq(1,0,1,1,0)',line) + +write(*,'(a)') '// Mapped sequence' + call dcl_type(parser,'map_seq(t:array(int)) is rec {array:t}',line) + call dcl_uproc(parser,'map_seq(x:grid_dim){var a=array(0,#x);forall i in a,j in x:i=j;'//& + 'return new map_seq{array=a}}',line) + call dcl_uproc(parser,'map_seq(x:array(int,mshape1d))=new map_seq {array=x} '//& + 'check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x)',line) + call dcl_uproc(parser,'_mono(x) {xs=#x;var ok=true;'//& + 'if x[low(xs.1)]x[i-1]:sync ok=false};return ok}' ,line) + + call dcl_uproc(parser,'map_seq(x:map_seq)=x',line) + + call dcl_uproc(parser,'#(x:map_seq)=#(x.array)',line) + call dcl_uproc(parser,'dims(x:map_seq)=size(x.array)',line) + call dcl_uproc(parser,'size(x:map_seq)=size(x.array)',line) + call dcl_uproc(parser,'+(x:map_seq,y:range_base)=new map_seq{array=x.array+y}',line) + call dcl_uproc(parser,'-(x:map_seq,y:range_base)=new map_seq{array=x.array-y}',line) + + call dcl_uproc(parser,'_arb(x:map_seq)=_arb(x.array)',line) + call dcl_uproc(parser,'element(x:map_seq,y:int)=element(x.array,y)',line) + + call dcl_proc(parser,'_intersect_aseq(&any,any,any,any,any,&any)',& + "intersect_aseq",0,line,0) + call dcl_proc(parser,'_overlap_aseq(&any,any,any,any,any,&any)',& + "intersect_aseq",1,line,0) + call dcl_proc(parser,'_overlap_aseq2(&any,any,any,any,any,&any,&any)',& + "intersect_aseq",2,line,0) + call dcl_proc(parser,'_expand_aseq(&any,any,any,&any,any,any)',& + "expand_aseq",0,line,0) + call dcl_proc(parser,'_intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any)',& + "intersect_bseq",0,line,0) + call dcl_proc(parser,'_overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any)',& + "intersect_bseq",1,line,0) + call dcl_proc(parser,'_overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any)',& + "intersect_bseq",2,line,0) + call dcl_proc(parser,'_includes_aseq(any,any,any,any)->bool',& + "includes_aseq",0,line,0) + call dcl_proc(parser,'_index_aseq(any,any,any)->int',& + "index_aseq",0,line,0) + call dcl_proc(parser,'_in_aseq(any,any,any)->bool',& + "in_aseq",0,line,0) + +!!$ call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq) {'//& +!!$ 'var a=array(0,[0..min(x._n,y._n)-1]);'//& +!!$ 'var n=0;_intersect_bseq(&n,a,x._lo,x._hi,x._b,x._st,x._align,'//& +!!$ 'y._lo,y._hi,y._b,y._st,y._align);'//& +!!$ 'v=new map_seq {array=a[0..n-1]};return v}',line) +!!$ +!!$ call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq) {'//& +!!$ 'var a=array(0,[0..min(x._n,y._n)-1]);'//& +!!$ 'var n=0;_overlap_bseq(&n,a,x._lo,x._hi,x._b,x._st,x._align,'//& +!!$ 'y._lo,y._hi,y._b,y._st,y._align);'//& +!!$ 'v=new map_seq {array=a[0..n-1]};return v}',line) +!!$ +!!$ call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq) {'//& +!!$ 'm=[0..min(x._n,y._n)-1];var a=array(0,m);var b=array(0,m);'//& +!!$ 'var n=0;_overlap_bseq2(&n,a,b,x._lo,x._hi,x._b,x._st,x._align,'//& +!!$ 'y._lo,y._hi,y._b,y._st,y._align);ns=shape([0..n-1]);'//& +!!$ 'v=new map_seq {array=a[ns]};w=new map_seq {array=b[ns]};return v,w}',line) + + call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y))',line) + call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y))',line) + + call dcl_uproc(parser,'overlap(x:block_seq,y:block_seq)=v,w'//& + ' where v,w=overlap(map_seq(x),map_seq(y))',line) + + + call dcl_uproc(parser,'intersect(x:map_seq,y:map_seq) {'//& + 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& + 'var n=0;_intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a);'//& + 'v=new map_seq {array=a[0..n-1]};return v}',line) + + call dcl_uproc(parser,'overlap(x:map_seq,y:map_seq) {'//& + 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& + 'var n=0;_overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a);'//& + 'v=new map_seq {array=a[0..n-1]};return v}',line) + + call dcl_uproc(parser,'overlap(x:map_seq,y:map_seq) {'//& + 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& + 'var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& + 'var n=0;_overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b);'//& + 'ns=[0..n-1];'//& + 'v=new map_seq {array=a[ns]};w=new map_seq {array=b[ns]};return v,w}',line) + + call dcl_uproc(parser,'overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x)',line) + + call dcl_uproc(parser,& + 'expand(t:map_seq,i:range(any_int)) {'//& + 'var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]);var m=0;'//& + '_expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i));'//& + 'v=new map_seq {array=a[0..m-1]};return v}',line) + + call dcl_uproc(parser,& + 'inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array))',line) + call dcl_uproc(parser,'inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y)',line) + call dcl_uproc(parser,'inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y)',line) + call dcl_uproc(parser,'inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y',line) + call dcl_uproc(parser,'in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y))',line) + call dcl_uproc(parser,'#(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y))',line) + + call dcl_uproc(parser,'empty(x:map_seq) {a=array(0,[1..0]);return new map_seq {array=a}}',line) + +write(*,'(a)') '// Grids (tuples of sequences)' + call dcl_type(parser,'_grid_dim(t:range_base) is seq(t),...',line) + call dcl_type(parser,'_grid_dim(t:int) is ...,block_seq,map_seq',line) + call dcl_type(parser,'grid_dim(t:range_base) is _grid_dim(t)',line) + call dcl_type(parser,'grid1d(t1:grid_dim) is [t1]',line) + call dcl_type(parser,'grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2]',line) + call dcl_type(parser,'grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is'//& + ' [t1,t2,t3]',line) + call dcl_type(parser,'grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is'//& + ' [t1,t2,t3,t4]',line) + call dcl_type(parser,'grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& + 't5:grid_dim) is'//& + ' [t1,t2,t3,t4,t5]',line) + call dcl_type(parser,'grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& + 't5:grid_dim,t6:grid_dim) is'//& + ' [t1,t2,t3,t4,t5,t6]',line) + call dcl_type(parser,'grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& + 't5:grid_dim,t6:grid_dim,t7:grid_dim) is'//& + ' [t1,t2,t3,t4,t5,t6,t7]',line) + call dcl_type(parser,'grid(t:range_base) is tuple(grid_dim(t))',line) + call dcl_uproc(parser,'#(x:grid)=shape(map($_shp,x))',line) + call dcl_uproc(parser,'dims(x:grid)=map($_size,x)',line) + call dcl_uproc(parser,'+(x:grid,y:tuple(range_base))=map($+,x,y)',line) + call dcl_uproc(parser,'-(x:grid,y:tuple(range_base))=map($+,x,y)',line) + call dcl_uproc(parser,'empty(x:grid)=map($empty,x)',line) + call dcl_uproc(parser,'element(x:grid_dim,y:grid_dim){var a=array(0,#y);'//& + 'forall i in a,j in y:i=x[j];'//& + 'return new map_seq{array=a}}',line) + call dcl_uproc(parser,'element(x:grid,y:grid)=map($element,x,y)',line) + +write(*,'(a)') '// Slices of grids (may have dims that are just an integer and also _ or _() or null)' + call dcl_type(parser,'grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null',line) + call dcl_type(parser,'grid_slice(t) is grid(t),tuple(grid_slice_dim(t))',line) + +write(*,'(a)') '// Some limited functionality for extended grids (which include cyclic ranges)' + call dcl_type(parser,'iterable_dim is grid_slice_dim,cyclic_range,...',line) + call dcl_type(parser,'iterable_grid is tuple(iterable_dim),grid_slice',line) + call dcl_uproc(parser,'_shp(x:iterable_dim)=0..size(x)-1',line) + call dcl_uproc(parser,'size(x:iterable_dim)->(int)...',line) + call dcl_uproc(parser,'element(x:iterable_dim,y)=error_type()'//& + 'check "Cannot index this type with a non-integer index"=>''false',line) + call dcl_uproc(parser,'element(x:iterable_dim,y:int)->(any)...',line) + call dcl_uproc(parser,'element(x:iterable_dim,y:tuple1d)=element(x,y.1)',line) + + + call dcl_uproc(parser,'_shp(x:stretch_dim)=null',line) + call dcl_uproc(parser,'_shp(x:null)=x',line) + call dcl_uproc(parser,'_size(x:stretch_dim or null)=''1',line) + call dcl_uproc(parser,'_size(x)=size(x)',line) + call dcl_proc(parser,'_act(x:single_point)->PM__tinyint',"miss_arg",0,line,0) + call dcl_uproc(parser,'_act(x)=x',line) + call dcl_uproc(parser,'_sliceit(arg...)=tuple(arg...)',line) + call dcl_uproc(parser,'active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x)',line) + call dcl_uproc(parser,'active_dims(x:single_point)=null',line) + call dcl_proc(parser,'_act(x:single_point,y:any)->PM__tinyint',"miss_arg",0,line,0) + call dcl_uproc(parser,'_act(x,y)=y',line) + call dcl_uproc(parser,'active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y)',line) + call dcl_uproc(parser,'active_dims(x:single_point,y)=null',line) + call dcl_uproc(parser,'_ar(x:single_point)=0',line) + call dcl_uproc(parser,'_ar(x)=1',line) + call dcl_uproc(parser,'rank(x:iterable_grid)=map_reduce($_ar,$+,x)',line) + call dcl_uproc(parser,'element(x:iterable_grid,y:index)'//& + '{t=_tup(y);return _ges(head(x),tail(x),head(t),tail(t),''false)}',line) + call dcl_uproc(parser,'element(x:grid_slice,arg...:grid_slice)'//& + '{t=_tup(arg...);'//& + 'return _ges(head(x),tail(x),head(t),tail(t),''true) }',line) + + call dcl_uproc(parser,'element(x:null,y)=null',line) + call dcl_uproc(parser,'_spnt(i,y:''true)=i',line) + call dcl_uproc(parser,'_spnt(i,y:''false)=i._t',line) + call dcl_uproc(parser,'_spif(i:int,y:''true)=single_point(i)',line) + call dcl_uproc(parser,'_spif(i,y:''true)=i',line) + call dcl_uproc(parser,'_spif(i,y:''false)=i',line) + call dcl_uproc(parser,'_ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) + call dcl_uproc(parser,'_ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => ''false',line) + call dcl_uproc(parser,'_ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),'//& + '_ges(head(x),tail(x),head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges_null(i,x,j,y,t:''true)='//& + 'prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges_null(i,x,j,y,t:''false)=_ges(head(x),tail(x),head(y),tail(y),t)',line) + call dcl_uproc(parser,'_ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t)',line) + call dcl_uproc(parser,'_ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges(i:single_point,x,j:empty_head,y,t)='//& + 'prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) + call dcl_uproc(parser,'_ges(i:empty_head,x,j:empty_head,y,t)=null',line) + call dcl_uproc(parser,'_ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => ''false',line) + call dcl_uproc(parser,'_ges(i:null,x,j:empty_head,y,t:''true)=error_type() :test "Rank mismatch" => ''false',line) + call dcl_uproc(parser,'_ges(i:null,x,j:empty_head,y,t:''false)=null',line) + + call dcl_uproc(parser,'size(x:iterable_grid)=map_reduce($_size,$*,x)',line) + call dcl_uproc(parser,'#(x:grid_slice)=shape(map($_shp,active_dims(x)))',line) + call dcl_uproc(parser,'dims(x:iterable_grid)=map($_size,active_dims(x))',line) + call dcl_uproc(parser,'_arb(x:grid_slice)=map($_arb,x)',line) + call dcl_uproc(parser,'in(x:tuple(range_base),y:grid_slice)='//& + 'map_reduce($in,$and,x,y)',line) + call dcl_uproc(parser,' inc(x:grid_slice,y:grid_slice)='//& + 'map_reduce($inc,$and,x,y)',line) + call dcl_uproc(parser,'#(x:grid,y:tuple(subs_dim))='//& + 'map($#,x,y)',line) + call dcl_proc(parser,'_acthash(x:single_point,y:any)->PM__tinyint',"miss_arg",0,line,0) + call dcl_uproc(parser,'_acthash(x,y)=x#y',line) + call dcl_uproc(parser,'#(x:grid_slice,y:tuple(subs_dim) or grid_slice)='//& + 'map_apply($_acthash,$_sliceit,x,y)',line) + call dcl_uproc(parser,'convert(x:grid_slice,y:real_num)=map_const($convert,x,y)',line) + call dcl_uproc(parser,'sint(x:grid_slice)=map($sint,x)',line) + call dcl_uproc(parser,'int(x:grid_slice)=map($int,x)',line) + call dcl_uproc(parser,'sreal(x:grid_slice)=map($sreal,x)',line) + call dcl_uproc(parser,'real(x:grid_slice)=map($real,x)',line) + call dcl_uproc(parser,'low(x:grid_slice)=map($low,x)',line) + call dcl_uproc(parser,'high(x:grid_slice)=map($high,x)',line) + call dcl_uproc(parser,'overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y)',line) + call dcl_uproc(parser,'overlap(x:grid_slice,y:grid_slice)=u,v'//& + ' where u,v=map($overlap,x,y)',line) + call dcl_uproc(parser,'intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y)',line) + call dcl_uproc(parser,'intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y))',line) + call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y))',line) + call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y))',line) + call dcl_uproc(parser,'expand(x:grid_slice,y:grid)='//& + 'map($expand,x,y)',line) + call dcl_uproc(parser,'contact(x:grid_slice,y:grid)='//& + 'map($contract,x,y)',line) + + call dcl_proc(parser,'gcd(x:int,y:int)->int',"gcd",0,line,0) + + + +write(*,'(a)') '// *****************************************************' +WRITE(*,'(A)') '// SHAPES' +write(*,'(a)') '// *****************************************************' + + call dcl_type(parser,'extent is tuple(range(int) ),'//& + 'extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d',line) + + call dcl_type(parser,'extent1d is tuple1d_of(range(int))',line) + call dcl_type(parser,'extent2d is tuple2d_of(range(int))',line) + call dcl_type(parser,'extent3d is tuple3d_of(range(int))',line) + call dcl_type(parser,'extent4d is tuple4d_of(range(int))',line) + call dcl_type(parser,'extent5d is tuple5d_of(range(int))',line) + call dcl_type(parser,'extent6d is tuple6d_of(range(int))',line) + call dcl_type(parser,'extent7d is tuple7d_of(range(int))',line) + call dcl_type(parser,'mshape(extent_t:extent) is '//& + 'rec {use _extent:extent_t,_n:int,_o:int}',line) + + call dcl_type(parser,'mshape1d is mshape(extent1d)',line) + call dcl_type(parser,'mshape2d is mshape(extent2d)',line) + call dcl_type(parser,'mshape3d is mshape(extent3d)',line) + call dcl_type(parser,'mshape4d is mshape(extent4d)',line) + call dcl_type(parser,'mshape5d is mshape(extent5d)',line) + call dcl_type(parser,'mshape6d is mshape(extent6d)',line) + call dcl_type(parser,'mshape7d is mshape(extent7d)',line) + +write(*,'(a)') '// Create array, vector and matrix shapes' + call dcl_uproc(parser,'_low(x)=low(x)',line) + call dcl_uproc(parser,'_low(x:null)=''0',line) + call dcl_uproc(parser,'_off(x)=-index(dims(x),map($_low,x))',line) + call dcl_uproc(parser,'PM__array(arg...)=shape(map($_extnt,[arg...]))',line) + call dcl_uproc(parser,'_extnt(n:any_int)=0..int(n)-1',line) + call dcl_uproc(parser,'_extnt(n:null)=null',line) + call dcl_uproc(parser,'_extnt(n:range(any_int))=int(n)',line) + + call dcl_uproc(parser,'shape(extent:extent)='//& + 'new mshape {_extent=extent,_n=size(extent),_o=_off(extent)}',line) + +write(*,'(a)') '// Conforming mshapes' + call dcl_uproc(parser,'check_conform(x,y) {check_conform(#x,#y)}',line) + call dcl_uproc(parser,'check_conform(x:mshape,y:mshape) {'//& + ' test "Mshapes "++x++" and "++y++" do not conform"=>'//& + 'conform(x,y)}',line) + call dcl_uproc(parser,'_conform(x,y)=size(x)==size(y)',line) + call dcl_uproc(parser,'_conform(x:null,y)=size(y)==''1',line) + call dcl_uproc(parser,'_conform(x,y:null)=''true',line) + call dcl_uproc(parser,'_conform(x:null,y:null)=''true',line) + call dcl_uproc(parser,'conform(x:mshape,y:mshape)='//& + 'map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0'//& + 'check "Values of different ranks cannot conform"=>rank(x)==rank(y)',line) + +write(*,'(a)') '// Local size of a mshape' + call dcl_uproc(parser,'_local_size(x:mshape)=size(x._extent)',line) + +write(*,'(a)') '// Convert an extent to have a zero base' + call dcl_uproc(parser,'zero_base(x:range)=0..size(x)-1',line) + call dcl_uproc(parser,'zero_base(x:extent)=map($zero_base,x)',line) + +write(*,'(a)') '// Extent of a mshape' + call dcl_uproc(parser,'extent(x:shape)=x._extent',line) + +write(*,'(a)') '// Dimensions of a mshape' + call dcl_uproc(parser,'dims(x:mshape)=map($size,x._extent)',line) + +write(*,'(a)') '// Size from dimensions' + call dcl_uproc(parser,'size(x:tuple(int))=reduce($*,x)',line) + +write(*,'(a)') '// Empty mshape' + call dcl_uproc(parser,'_empty(x)=1..0',line) + call dcl_uproc(parser,'empty(x:extent)=map($_empty,x)',line) + +write(*,'(a)') '// Slice of mshape' + call dcl_uproc(parser,'[](x:mshape,s:index)=x._extent[s]',line) + call dcl_uproc(parser,'[](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,''true))):'//& + 'check_contains(x,s)',line) + +write(*,'(a)') '// *****************************************************' +WRITE(*,'(A)') '// INDEXING AND SLICING' +write(*,'(a)') '// *****************************************************' + +write(*,'(a)') '// Generic types supporting indexing and mapping' + call dcl_type(parser,'iterable is iterable_grid,'//& + 'grid_slice,grid,grid_slice_dim,cyclic_range,array,...',line) + call dcl_uproc(parser,'[](x:iterable,arg...)'//& + '{d=#x;y=_tup(arg...);check_contains(d,y);return element(x,fill_in(d,y,''false))}',line) + +write(*,'(a)') '// Index type' + call dcl_type(parser,'index is any_int,tuple(any_int)',line) + +write(*,'(a)') '// Slice and subscript types' + call dcl_type(parser,'range_below(x) is rec {_t:x}',line) + call dcl_type(parser,'range_above(x) is rec {_t:x}',line) + call dcl_type(parser,& + 'strided_range_below(x) is rec {_t:x,_st:x}',line) + call dcl_type(parser,& + 'strided_range_above(x) is rec {_t:x,_st:x}',line) + call dcl_type(parser,'stride(x) is rec {_st:x}',line) + call dcl_type(parser,'slice_dim is'//& + ' range(any_int),strided_range(any_int),range_above(any_int),'//& + ' range_below(any_int),strided_range_above(any_int),strided_range_below(any_int),'//& + ' stride(any_int),null,stretch_dim',& + line) + call dcl_type(parser,'slice is slice_dim,tuple(slice_dim)'& + ,line) + call dcl_type(parser,'subs_dim is slice_dim,any_int',line) + call dcl_type(parser,'subs is index,slice,subs_dim,tuple(subs_dim)',line) + + +write(*,'(a)') '// Partial ranges/sequences mainly used in subscripts' + call dcl_uproc(parser,'..._(x)=new range_below {_t=x}',line) + call dcl_uproc(parser,'_...(x)=new range_above {_t=x}',line) + call dcl_uproc(parser,'by(x:range_base)=new stride {_st=x}',line) + call dcl_uproc(parser,'by(x:range_above(),y)='//& + 'new strided_range_above {_t=x._t,_st=convert(y,x._t)}',line) + call dcl_uproc(parser,'by(x:range_below(),y)='//& + 'new strided_range_below {_t=x._t,_st=convert(y,x._t)}',line) + call dcl_uproc(parser,'string(x:range_above)=x._t++"..."',line) + call dcl_uproc(parser,'string(x:range_below)="..."++x._t',line) + call dcl_uproc(parser,'string(x:strided_range_above)=x._t++"... by"++x._st',line) + call dcl_uproc(parser,'string(x:strided_range_below)="..."++x._t++"by "++x._st',line) + call dcl_uproc(parser,'string(x:stride)="by "++x._st',line) + call dcl_uproc(parser,'low(x:range_above)=x._t',line) + call dcl_uproc(parser,'low(x:strided_range_above)=x._t',line) + call dcl_uproc(parser,'high(x:range_below)=x._t',line) + call dcl_uproc(parser,'high(x:strided_range_below)=x._t',line) + call dcl_uproc(parser,'step(x:range_above or range_below)=''1',line) + call dcl_uproc(parser,'step(x:strided_range_above or strided_range_below)=x._st',line) + call dcl_uproc(parser,'width(x:strided_range_above or strided_range_below or '//& + 'range_above or range_below)=''1',line) + +write(*,'(a)') '// Stretch dimension in subscript' + call dcl_type(parser,'stretch_dim is unique{PM__strdim}',line) + call dcl_uproc(parser,'string(x:stretch_dim)="_"',line) + call dcl_uproc(parser,'size(x:stretch_dim)=''1',line) + call dcl_uproc(parser,'expand(x:stretch_dim,y:grid)=x',line) + call dcl_uproc(parser,'contract(x:stretch_dim,y:grid)=x',line) + call dcl_uproc(parser,'in(x:stretch_dim,y)=''true',line) + call dcl_uproc(parser,' inc(x:stretch_dim,y)=''true',line) + call dcl_uproc(parser,'convert(x:stretch_dim,y:range_base)=x',line) + call dcl_uproc(parser,'#(x:stretch_dim,y:index)=''0',line) + call dcl_uproc(parser,'#(x:stretch_dim,y:grid_slice_dim)=''0..''0',line) + call dcl_uproc(parser,'intersect(x:stretch_dim,y:grid_slice_dim)=y',line) + call dcl_uproc(parser,'intersect(x:grid_slice_dim,y:stretch_dim)=x',line) + call dcl_uproc(parser,'intersect(x:stretch_dim,y:stretch_dim)=x',line) + call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:stretch_dim)=#x',line) + call dcl_uproc(parser,'overlap(x:stretch_dim,y:grid_slice_dim)=''0..''0',line) + call dcl_uproc(parser,'overlap(x:stretch_dim,y:stretch_dim)=''0..''0',line) + +write(*,'(a)') '// Check subscript is in range' + call dcl_uproc(parser,'check_contains(a:extent,arg...) '//& + '{test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...)}',line) + call dcl_uproc(parser,'check_contains(a:mshape,arg...) {check_contains(a._extent,arg...)}',line) + call dcl_uproc(parser,'check_contains(a,arg...) {check_contains(#a,arg...)}',line) + call dcl_uproc(parser,'check_contains(a:dshape,arg...) {check_contains(a._mshape._extent,arg...)}',line) + call dcl_uproc(parser,'_contains(x:null,y)=''true',line) + call dcl_uproc(parser,'_contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y)',line) + call dcl_uproc(parser,'_contains(x:range(int),y:range(any_int) or seq(any_int))='//& + '_contains(x,y._lo) and _contains(x,y._hi) or y._lo>y._hi',line) + call dcl_uproc(parser,'_contains(x:range(int),y:range_below(any_int) or '//& + 'strided_range_below(any_int) or range_above(any_int) or '//& + 'strided_range_above(any_int))=_contains(x,y._t)',line) + call dcl_uproc(parser,'_contains(x:range(int),y:stride(any_int))=''true',line) + call dcl_uproc(parser,'_contains(x:range(int),y:null)=''true',line) + call dcl_uproc(parser,'contains(x:mshape1d,y:subs_dim)='//& + '_contains(x.1,y)',line) + call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim))='//& + 'map_reduce($_contains,$and,x,y)',line) + call dcl_proc(parser,'_rgd(x:stretch_dim)->PM__tinyint',"miss_arg",0,line,0) + call dcl_uproc(parser,'_rgd(x)=x',line) + call dcl_uproc(parser,'_rigid_dims(x:grid_slice or tuple(subs_dim))='//& + 'map_apply($_rgd,$_sliceit,x)',line) + call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim)'//& + ' and contains(stretch_dim))=contains(x,_rigid_dims(y))',line) + call dcl_uproc(parser,'contains(x:extent,y,arg...)=contains(x,[y,arg...])',line) + +write(*,'(a)') '// Complete a subscript using a base mshape' + call dcl_uproc(parser,& + 'fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => ''false',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int,t:''true)=single_point(int(y))',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int,t:''false)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int,t:null)=int(y)..int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:range(any_int),t)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:strided_range(any_int),t)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:range_below(any_int),t)=x._lo..int(y._t)',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:range_above(any_int),t)=int(y._t)..x._hi',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_below(any_int),t)=lo..int(y._t) by y._st'//& + ' where lo=y._t-(y._t-x._lo)/y._st*y._st',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_above(any_int),t)=int(y._t)..x._hi by y._st',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:stride(any_int),t)=x by int(y._st)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:null,t)=x',line) + call dcl_uproc(parser,'fill_in(x:grid,y:tuple(any_int),t)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim),t)=map($fill_in,x,y,spread(t,x))',line) + call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim),t)='//& + '_fill_in(x,head(y),tail(y),t)',line) + call dcl_uproc(parser,'_fill_in(x,y,z,t)=prepend(fill_in(x.1,y,t),'//& + '_fill_in(tail(x),head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x,y:stretch_dim,z,t:''true)='//& + 'prepend(null,_fill_in(x,head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x,y:stretch_dim,z,t:''false)='//& + 'prepend(y,_fill_in(x,head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x:null,y:empty_head,z,t)=null',line) + call dcl_uproc(parser,& + '_fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x:empty_head,y,z,t)='//& + 'error_type() :test "Rank mismatch in slice" => ''false',line) + +write(*,'(a)') '// *******************************************************' +WRITE(*,'(A)') '// SUBSCRIPT INTERSECTION AND ALIASING' +write(*,'(a)') '// *******************************************************' + +write(*,'(a)') '// Test for intersection between two subscripts' + call dcl_uproc(parser,'intersects(x:null,y:subs_dim)=''true',line) + call dcl_uproc(parser,'intersects(x:subs_dim,y:null)=''true',line) + call dcl_uproc(parser,'intersects(x:null,y:null)=''true',line) + call dcl_uproc(parser,'intersects(x:range(any_int),y:range(any_int))='//& + 'not(x._hiy._hi)',line) + call dcl_uproc(parser,'intersects(x:seq(any_int),y:seq(any_int))=size(intersect(x,y))>0',line) + call dcl_uproc(parser,'intersects(x:range(any_int),'//& + 'y:range_above(any_int) or strided_range_above(any_int))=x._hi>=y._t',line) + call dcl_uproc(parser,'intersects(x:range_above(any_int) or strided_range_above(any_int),'//& + 'y:range(any_int))=y._hi>=x._t',line) + call dcl_uproc(parser,'intersects(x:range(any_int),'//& + 'y:range_below(any_int) or strided_range_below(any_int))=x._lo<=y._t',line) + call dcl_uproc(parser,'intersects(x:range_below(any_int) or strided_range_below(any_int),'//& + 'y:range(any_int))=y._lo<=x._t',line) + call dcl_uproc(parser,'intersects(x:strided_range(any_int),'//& + 'y:range_above(any_int) or strided_range_above(any_int))='//& + 'intersects(y._t..x._hi by step(y),x)',line) + call dcl_uproc(parser,'intersects(y:range_above(any_int) or strided_range_above(any_int),'//& + 'x:strided_range(any_int))=intersects(y._t..x._hi by step(y),x)',line) + call dcl_uproc(parser,'intersects(x:strided_range(any_int),'//& + 'y:range_below(any_int) or strided_range_below(any_int))='//& + 'intersects(x,y._t..x._lo by -step(y))',line) + call dcl_uproc(parser,'intersects(y:range_below(any_int) or strided_range_below(any_int),'//& + 'x:strided_range(any_int))='//& + 'intersects(x,y._t..x._lo by -step(y))',line) + call dcl_uproc(parser,'intersects(x:range_below(any_int) or strided_range_below(any_int),'//& + 'y:range_above(any_int) or strided_range_above(any_int))=x._t>=y._t',line) + call dcl_uproc(parser,'intersects(x:range_above(any_int) or strided_range_above(any_int),'//& + 'y:range_below(any_int) or strided_range_below(any_int))=y._t>=x._t',line) + call dcl_uproc(parser,'intersects(x:range_above(any_int) or strided_range_above(any_int),'//& + 'y:range_above(any_int) or strided_range_above(any_int))=''true',line) + call dcl_uproc(parser,'intersects(x:range_below(any_int) or strided_range_below(any_int),'//& + 'y:range_below(any_int) or strided_range_below(any_int))=''true',line) + call dcl_uproc(parser,'intersects(x:strided_range_below(any_int),'//& + 'y:strided_range_above(any_int))='//& + 'size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0',line) + call dcl_uproc(parser,'intersects(y:strided_range_above(any_int),'//& + 'x:strided_range_below(any_int))='//& + 'size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0',line) + call dcl_uproc(parser,'intersects(x:strided_range_above(any_int),'//& + 'y:strided_range_above(any_int))=abs(x._t-y._t) mod gcd(int(x._st),int(y._st))==0',& + line) + call dcl_uproc(parser,'intersects(x:strided_range_below(any_int),'//& + 'y:strided_range_below(any_int))='//& + 'abs(x._t-y._t) mod gcd(abs(int(x._st)),abs(int(y._st)))==0',& + line) + call dcl_uproc(parser,'intersects(x:stride(any_int),y:subs_dim)=''true',line) + call dcl_uproc(parser,'intersects(x:subs_dim,y:stride(any_int))=''true',line) + call dcl_uproc(parser,'intersects(x:stride(any_int),y:stride(any_int))=''true',line) + + call dcl_uproc(parser,'intersects(x:seq,y:int)=y in x',line) + call dcl_uproc(parser,'intersects(x:int,y:seq)=x in y',line) + call dcl_uproc(parser,'intersects(x:int,y:int)=x==y',line) + + call dcl_uproc(parser,'intersects(x:int,y:range_above(any_int))=x>=y._t',line) + call dcl_uproc(parser,'intersects(x:int,y:range_below(any_int))=x<=y._t',line) + call dcl_uproc(parser,'intersects(x:int,y:strided_range_above(any_int))='//& + 'x>=y._t and (x-y._t) mod y._st==0',line) + call dcl_uproc(parser,'intersects(x:int,y:strided_range_below(any_int))='//& + 'x<=y._t and (y._t-x) mod y._st==0',line) + call dcl_uproc(parser,'intersects(y:range_above(any_int),x:int)=x>=y._t',line) + call dcl_uproc(parser,'intersects(y:range_below(any_int),x:int)=x<=y._t',line) + call dcl_uproc(parser,'intersects(y:strided_range_above(any_int),x:int)='//& + 'x>=y._t and (x-y._t) mod y._st==0',line) + call dcl_uproc(parser,'intersects(y:strided_range_below(any_int),x:int)='//& + 'x<=y._t and (y._t-x) mod y._st==0',line) + call dcl_uproc(parser,'_intersects(x,y,z:''true)=map_reduce($intersects,$and,x,y)',line) + call dcl_uproc(parser,'_intersects(x,y,z:''false)=''false',line) + call dcl_uproc(parser,'intersects(x:tuple(subs_dim except stretch_dim),'//& + 'y:tuple(subs_dim except stretch_dim))=_intersects(x,y,rank(x)==rank(y))',line) + call dcl_uproc(parser,'intersects(x:tuple(subs_dim),y:tuple(subs_dim))='//& + '_intersects(rx,ry,rank(rx)==rank(ry))'//& + 'where rx=_rigid_dims(x),ry=_rigid_dims(y)',line) + call dcl_uproc(parser,'intersects(x:tuple(subs_dim),y:null)=''true',line) + call dcl_uproc(parser,'intersects(x:null,y:tuple(subs_dim))=''true',line) + + call dcl_uproc(parser,'_intersects(x:subs,y:subs)=intersects(x,y)',line) + call dcl_uproc(parser,'_intersects(x,y)=''false',line) + +write(*,'(a)') '// Alias checking' + call dcl_uproc(parser,'PM__check_alias(arg...)=false',line) + call dcl_uproc(parser,'PM__check_alias(i,j,x,y) {'//& + 'test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) }',line) + call dcl_uproc(parser,'PM__check_alias(i,j,x,y,arg...) {'//& + 'if _intersects(x,y):PM__check_alias(i,j,arg...)}',line) + +write(*,'(a)') '// Combining subscripts' + call dcl_uproc(parser,'PM__cmbidx(x,y)=_cmb(x,y)',line) + call dcl_uproc(parser,'PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...)',line) + call dcl_type(parser,'_cmb_error is unique',line) + call dcl_uproc(parser,'_cmb(x,y)=_cmb_error',line) + call dcl_uproc(parser,'_cmb(x:subs except index,y:subs)=_cmb1(x,y)',line) + call dcl_uproc(parser,'_cmb1(x,y)=_cmb_error',line) + call dcl_uproc(parser,'_cmb1(x:subs_dim,y:subs_dim)=x[y]',line) + call dcl_uproc(parser,'_cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y))',line) + call dcl_uproc(parser,'_cmb2(x,y,z:''true)=x[y]',line) + call dcl_uproc(parser,'_cmb2(x,y,z:''false)=_cmb_error',line) + +write(*,'(a)') '// *******************************************************' +WRITE(*,'(A)') '// ITERATION - SEQUENTIAL AND CONCURRENT' +write(*,'(a)') '// *******************************************************' + +write(*,'(a)') '// Iteration over mshape' + +write(*,'(a)') '// - first element' + call dcl_uproc(parser,'PM__first(d:int)=0,null,d>0',line) + call dcl_uproc(parser,'PM__first(d:tuple1d)='//& + 'i,s,e where i,s,e=PM__first(d.1)',line) + call dcl_uproc(parser,'PM__first(d:tuple2d)='//& + '[j1,j2],[s1,s2],e1 and e2'//& + ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2)',line) + call dcl_uproc(parser,'PM__first(d:tuple3d)='//& + '[j1,j2,j3],[s1,s2,s3],e1 and e2 and e3'//& + ' where j1,s1,e1=PM__first(d.1),'//& + 'j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3)',& + line) + call dcl_uproc(parser,'PM__first(d:tuple4d)='//& + '[j1,j2,j3,j4],[s1,s2,s3,s4],'//& + 'e1 and e2 and e3 and e4'//& + ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),'//& + 'j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4)',line) + call dcl_uproc(parser,'PM__first(d:tuple5d)=[j1,j2,j3,j4,j5],'//& + ' [s1,s2,s3,s4,s5],'//& + 'e1 and e2 and e3 and e4 and e5'//& + ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,'//& + 'e3=PM__first(d.3),j4,s4,e4=PM__first(d.4),'//& + ' j5,s5,e5=PM__first(d.5)',line) + call dcl_uproc(parser,'PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],'//& + '[s1,s2,s3,s4,s5,s6],'//& + 'e1 and e2 and e3 and e4 and e5 and e6'//& + ' where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),'//& + 'j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4),'//& + ' j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6)',line) + call dcl_uproc(parser,'PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],'//& + '[s1,s2,s3,s4,s5,s6,s7],'//& + 'e1 and e2 and e3 and e4 and e5 and e6 and e7'//& + ' where j1,s1,e1=PM__first(d.1),j2,s2,'//& + 'e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),'//& + 'j4,s4,e4=PM__first(d.4),'//& + ' j5,s5,e5=PM__first(d.5),'//& + 'j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7)',line) + +write(*,'(a)') '// - subsequent elements' + call dcl_uproc(parser,'PM__next(d:int,g,i)=ii,null,iiint',& + "do_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_doloop(int,int)->int,int',& + "do_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_doloop(int,int,int)->int,int,int',& + "do_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_doloop(int,int,int,int)->int,int,int,int',& + "do_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_doloop(int,int,int,int,int)->int,int,int,int,int',& + "do_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_doloop(int,int,int,int,int,int)->int,int,int,int,int,int',& + "do_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_doloop(int,int,int,int,int,int,int)->'//& + 'int,int,int,int,int,int,int',& + "do_loop",0,line,& + proc_is_generator) + call dcl_uproc(parser,& + '_elts(x:int)=i '//& + 'where i=_doloop(x)',line) + call dcl_uproc(parser,& + '_elts(x:tuple1d)=[i] where i=_elts(x.1)',line) + call dcl_uproc(parser,& + '_elts(x:tuple2d)=[i,j] where '//& + 'i,j=_doloop(x.1,x.2)',line) + call dcl_uproc(parser,& + '_elts(x:tuple3d)=[i,j,k] where '//& + 'i,j,k=_doloop(x.2,x.2,x.3)',line) + call dcl_uproc(parser,& + '_elts(x:tuple4d)=[i,j,k,l] where '//& + 'i,j,k,l=_doloop(x.1,x.2,x.3,x.4)',line) + call dcl_uproc(parser,& + '_elts(x:tuple5d)=[i,j,k,l,m] where '//& + 'i,j,k,l,m=_doloop(x.1,x.2,x.3,x.4,x.5)',line) + call dcl_uproc(parser,& + '_elts(x:tuple6d)=[i,j,k,l,m,n] where '//& + 'i,j,k,l,m,n=_doloop(x.1,x.2,x.3,x.4,x.5,x.6)',line) + call dcl_uproc(parser,& + '_elts(x:tuple7d)=[i,j,k,l,m,n,o] where '//& + 'i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7)',line) + + call dcl_proc(parser,& + '_blockedloop(any)->int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_blockedloop(any)->int,int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_blockedloop(any)->int,int,int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_blockedloop(any)->int,int,int,int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_blockedloop(any)->int,int,int,int,int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_blockedloop(any)->int,int,int,int,int,int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_blockedloop(any)->'//& + 'int,int,int,int,int,int,int',& + "blocked_loop",0,line,& + proc_is_generator) + call dcl_uproc(parser,& + '_belts(x,y:shape1d)=[i] where '//& + 'i=_blockedloop(PM__do_over(x,y))',line) + call dcl_uproc(parser,& + '_belts(x,y:shape2d)=[i,j] where '//& + 'i,j=_blockedloop(PM__do_over(x,y))',line) + call dcl_uproc(parser,& + '_belts(x,y:shape3d)=[i,j,k] where '//& + 'i,j,k=_blockedloop(PM__do_over(x,y))',line) + call dcl_uproc(parser,& + '_belts(x,y:shape4d)=[i,j,k,l] where '//& + 'i,j,k,l=_blockedloop(PM__do_over(x,y))',line) + call dcl_uproc(parser,& + '_belts(x,y:shape5d)=[i,j,k,l,m] where '//& + 'i,j,k,l,m=_blockedloop(PM__do_over(x,y))',line) + call dcl_uproc(parser,& + '_belts(x,y:shape6d)=[i,j,k,l,m,n] where '//& + 'i,j,k,l,m,n=_blockedloop(PM__do_over(x,y))',line) + call dcl_uproc(parser,& + '_belts(x,y:shape7d)=[i,j,k,l,m,n,o] where '//& + 'i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y))',line) +write(*,'(a)') 'PM__else' + + call dcl_uproc(parser,'PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n)',line) + call dcl_uproc(parser,'PM__generate(x:mshape,n,s)=_elts(dims(x),1,n)',line) + + call dcl_proc(parser,& + '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->int',& + "iota",0,line,& + proc_is_generator) + call dcl_proc(parser,& + '_iota(siz:int,start:int,finish:int,incr:int,'//& + 'first:int,trunc:int,totsiz:int)->int',& + "iota",0,line,& + proc_is_generator) + call dcl_uproc(parser,'_n(x:int)=x',line) + call dcl_uproc(parser,& + '_elts(x:int,siz,tot)=_iota(siz,0,x-1,1,tot)',line) + call dcl_uproc(parser,& + '_elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot))',line) + call dcl_uproc(parser,& + '_elts(x:tuple2d,siz,tot)='//& + 'tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) )',line) + call dcl_uproc(parser,& + '_elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),'//& + '_elts(x.2,s1,tot),'//& + '_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1)',line) + call dcl_uproc(parser,& + '_elts(x:tuple4d,siz,tot)='//& + 'tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),'//& + '_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) '//& + 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) + call dcl_uproc(parser,& + '_elts(x:tuple5d,siz,tot)='//& + 'tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),'//& + '_elts(x.3,s2,tot),_elts(x.4,s3,tot),'//& + '_elts(x.5,s3*_n(x.4), tot)) '//& + 'where s3=s2*_n(x.3) where s2=s1*_n(x.2) '//& + 'where s1=siz*_n(x.1)',& + line) + call dcl_uproc(parser,& + '_elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),'//& + '_elts(x.2,s1,tot),'//& + '_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),'//& + '_elts(x.6,s4*_n(x.5), tot)) '//& + 'where s4=s3*_n(x.4) where s3=s2*_n(x.3) '//& + 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) + call dcl_uproc(parser,& + '_elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),'//& + '_elts(x.2,s1,tot),'//& + '_elts(x.3,s2,tot),_elts(x.4,s3,tot),'//& + '_elts(x.5,s4,tot),_elts(x.6,s5,tot),'//& + '_elts(x.7,s5*_n(x.6), tot)) '//& + 'where s5=s4*_n(x.5) where s4=s3*_n(x.4) '//& + 'where s3=s2*_n(x.3) '//& + 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) +write(*,'(a)') 'PM__endif' + + call dcl_proc(parser,& + '_indices(any)->int',"indices",0,line,0) + +write(*,'(a)') '// **************************************' +WRITE(*,'(A)') '// ARRAYS' +write(*,'(a)') '// **************************************' + +write(*,'(a)') '// Array types' + call dcl_type(parser,& + 'array(e,d:shape) is varray(e,d),farray(e,d)',line) + call dcl_type(parser,'varray(e,d:shape) is'//& + ' e^var d,array_template(e,d,''true)',line) + call dcl_type(parser,'farray(e,d:shape) is'//& + ' e^const d,e^invar d,e^fix d,array_template(e,d,''false)',line) + call dcl_type(parser,'farray(e,d:mshape) is ...,'//& + 'array_slice(e^const any),array_slice(e^var any),'//& + 'array_slice(e^invar any),array_slice(e^fix any)',line) + +write(*,'(a)') '// Array operations' + call dcl_uproc(parser,'_arb(x:any^mshape)='//& + '_get_aelem(x,0)',line) + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'size(x:any^mshape)=size(#x)',line) +write(*,'(a)') 'PM__else' + call dcl_proc(parser,'size(x:any^mshape)->int',"get_size",0,line,0) +write(*,'(a)') 'PM__endif' + call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->PM__dim x,y',& + "array",0,line,proc_needs_type) + call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->PM__vdim x,y',& + "var_array",0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& +!!$ "array",0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& +!!$ merge("init_farray","array",pm_is_compiling),0,line,proc_needs_type) + call dcl_proc(parser,& + '_redim(x:any^any,y:any)->over x,y',& + "redim",0,line,proc_needs_type) + call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->PM__dim x,y',& + "array_noinit",0,line,proc_needs_type) + + call dcl_uproc(parser,'#%(x:invar any^any)=_array_shape(x <>)',line) + call dcl_uproc(parser,'#%(x)=_get_shape(x)',line) + call dcl_uproc(parser,'_get_shape(x)=#x',line) + call dcl_uproc(parser,'#(x:any^any)=_array_shape(x)',line) + call dcl_proc(parser,'_array_shape(x:any^any)->#x',"get_dom",0,line,0) + call dcl_uproc(parser,'dims(x:any^mshape)=dims(#x)',line) + call dcl_proc(parser,'PM__extractelm(x:any^any)->%x',& + "extractelm",0,line,0) + + call dcl_uproc(parser,'element(a:any^mshape,t:index)='//& + '_get_aelem(a,index(#(a),t))',line) + call dcl_uproc(parser,'_set_elem(&a:any^mshape,v,t:index)'//& + '{ PM__setaelem(&a,index(#(a),t),v) }',line) + call dcl_uproc(parser,'_make_subref(a:any^mshape,t:index)='//& + '_make_subref(a,index(#(a),t))',line) + call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->%a',& + "make_rf",0,line,0) + + call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->%x',& + "array_get_elem",0,line,0) + call dcl_proc(parser,'PM__setaelem(&x:any^any,y:int,z:any)',& + "array_set_elem",0,line,0) + +write(*,'(a)') '// Linear index of tuple mshape (zero base,unit stride)' + call dcl_uproc(parser,'_indx(g:null,s)=''0',line) + call dcl_uproc(parser,'_indx(g:range(int),s)=int(s)',line) + call dcl_uproc(parser,'_indx(g:any_int,s)=int(s)',line) + call dcl_uproc(parser,'_sz(x:null)=''1',line) + call dcl_uproc(parser,'_sz(x:int)=x',line) + call dcl_uproc(parser,'_sz(x:range(int))=x._n',line) + call dcl_uproc(parser,'_offset(x:mshape)=x._o',line) + call dcl_uproc(parser,'_offset(x)=''0',line) + call dcl_uproc(parser,'index(g:mshape1d or tuple1d_of(int),s:any_int)=int(_indx(g.1,s))+_offset(g)',line) + call dcl_uproc(parser,'index(g:mshape1d or tuple1d_of(int),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g)',line) + call dcl_uproc(parser,'index(g:mshape2d or tuple2d_of(int),s:tuple2d_of(any_int))='//& + 'int(_indx(g.1,s.1)+_sz(g.1)*'//& + '_indx(g.2,s.2))+_offset(g)',line) + call dcl_uproc(parser,'index(g:mshape3d or tuple3d_of(int),s:tuple3d_of(any_int))='//& + 'int(_indx(g.1,s.1)+_sz(g.1)*'//& + '(_indx(g.2,s.2)+_sz(g.2)*'//& + '_indx(g.3,s.3)))+_offset(g)',line) + call dcl_uproc(parser,& + 'index(g:mshape4d or tuple4d_of(int),s:tuple4d_of(any_int))='//& + ' int(_indx(g.1,s.1)+_sz(g.1)*'//& + ' (_indx(g.2,s.2)+_sz(g.2)*'//& + ' (_indx(g.3,s.3)+_sz(g.3)*'//& + ' _indx(g.4,s.4))))+_offset(g)',line) + call dcl_uproc(parser,& + 'index(g:mshape5d or tuple5d_of(int),s:tuple5d_of(any_int))='//& + ' int(_indx(g.1,s.1)+_sz(g.1)*'//& + ' (_indx(g.2,s.2)+_sz(g.2)*'//& + ' (_indx(g.3,s.3)+_sz(g.3)*'//& + ' (_indx(g.4,s.4)+_sz(g.4)*'//& + ' _indx(g.5,s.5)))))+_offset(g)',line) + call dcl_uproc(parser,& + 'index(g:mshape6d or tuple6d_of(int),s:tuple6d_of(any_int))='//& + ' int(_indx(g.1,s.1)+_sz(g.1)*'//& + ' (_indx(g.2,s.2)+_sz(g.2)*'//& + ' (_indx(g.3,s.3)+_sz(g.3)*'//& + ' (_indx(g.4,s.4)+_sz(g.4)*'//& + ' (_indx(g.5,s.5)+_sz(g.5)*'//& + ' _indx(g.6,s.6))))))+_offset(g)',line) + call dcl_uproc(parser,& + 'index(g:mshape7d or tuple7d_of(int),s:tuple7d_of(any_int))='//& + ' int(_indx(g.1,s.1)+_sz(g.1)*'//& + ' (_indx(g.2,s.2)+_sz(g.2)*'//& + ' (_indx(g.3,s.3)+_sz(g.3)*'//& + ' (_indx(g.4,s.4)+_sz(g.4)*'//& + ' (_indx(g.5,s.5)+_sz(g.5)*'//& + ' (_indx(g.6,s.6)+_sz(g.6)*'//& + ' (_indx(g.7,s.7))))))))+_offset(g)',line) + + call dcl_uproc(parser,'index2point(i:int,s:range(int))=[i+s._lo]',line) + call dcl_uproc(parser,'index2point(i:int,s:int)=[i]',line) + call dcl_uproc(parser,'index2point(i:int,s:tuple1d_of(int))=[i]',line) + call dcl_uproc(parser,& + 'index2point(i:int,s:tuple2d_of(int))='//& + '[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1)',line) + call dcl_uproc(parser,'index2point(i:int,s:tuple3d_of(int))='//& + '[i1,i2,i3] where i1=i-j2*_sz(s.1) '//& + 'where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) + call dcl_uproc(parser,& + 'index2point(i:int,s:tuple4d_of(int))='//& + '[i1,i2,i3,i4]'//& + ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& + ' where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3)'//& + ' where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) + call dcl_uproc(parser,& + 'index2point(i:int,s:tuple5d_of(int))='//& + '[i1,i2,i3,i4,i5]'//& + ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& + ' where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) '//& + ' where i5=j4/_sz(s.4)'//& + ' where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) + call dcl_uproc(parser,'index2point(i:int,s:tuple6d_of(int))='//& + '[i1,i2,i3,i4,i5,i6]'//& + ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& + ' where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) '//& + ' where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5)'//& + ' where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) + call dcl_uproc(parser,'index2point(i:int,s:tuple7d_of(int))='//& + '[i1,i2,i3,i4,i5,i6,i7]'//& + ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& + ' where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) '//& + ' where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6)'//& + ' where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3)'//& + ' where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) + +write(*,'(a)') '// Numeric array operations' + call dcl_uproc(parser,'-(x:num^any)={-xx:xx in x}',line) + call dcl_uproc(parser,'+(x:num^any,y:num)={xx+y:xx in x}',line) + call dcl_uproc(parser,'-(x:num^any,y:num)={xx-y:xx in x}',line) + call dcl_uproc(parser,'*(x:num^any,y:num)={xx*y:xx in x}',line) + call dcl_uproc(parser,'*(x:num,y:num^any)={x*yy:yy in y}',line) + call dcl_uproc(parser,'/(x:num^any,y:num)={xx/y:xx in x}',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// ARRAY TEMPLATES' +write(*,'(a)') '// *****************************************' + +write(*,'(a)') '// Array templates' + call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool)'//& + ' is rec {_a:a,_d:d,_s:int,_v:v}',line) + call dcl_uproc(parser,& + 'array(a:any,s:dshape)='//& + 'new array_template {_a=a,_d=s,_s=s._size,_v=''false}',line) + call dcl_uproc(parser,& + 'array(a:any,s:mshape(tuple(range(int))))='//& + 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) + call dcl_uproc(parser,& + 'array(a:any,s:tuple(range(any_int)))=array(a,shape(s))',line) + + call dcl_uproc(parser,& + 'varray(a:any,s:mshape or dshape)='//& + 'new array_template {_a=a,_d=s,_s=size(s),_v=''true}',line) + call dcl_uproc(parser,& + 'varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s))',line) + call dcl_uproc(parser,'_zero(x)=0',line) + call dcl_uproc(parser,& + 'varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s)))',line) + +write(*,'(a)') '// Treat a template as if it were an array' + call dcl_uproc(parser,'_arb(a:array_template)=a._a',line) + call dcl_uproc(parser,'#(a:array_template(,mshape,))=a._d',line) + call dcl_uproc(parser,'dims(a:array_template(,mshape,))=dims(a._d)',line) + call dcl_uproc(parser,'size(a:array_template)=a._s',line) + call dcl_uproc(parser,'redim(a:array_template,d:mshape)='//& + ' new array_template { _a=a,_d=d,_s=size(d),_v=a._v}'//& + ' check "New dshape does not have same size in redim"=>'//& + ' size(d)==a._s',line) + call dcl_uproc(parser,'element(a:array_template,arg...:subs)=a._a',line) + +write(*,'(a)') '// Array creation from template' + call dcl_uproc(parser,'PM__dup(a:array_template(,shape,))='//& + '_array(PM__dup(a._a),a._d,int(a._s),a._v)',line) + call dcl_uproc(parser,'PM__dup(a:array_template(,shape,''true))='//& + '_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v)',line) + + call dcl_uproc(parser,'PM__do_dim(a:any,d:mshape)='//& + '_array(a,d,size(d),''false)',& + line) + + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// MATRIX AND VECTOR' +write(*,'(a)') '// *****************************************' + + call dcl_type(parser,'matrix_element is num,bool,...',line) + call dcl_type(parser,'_matrix(t) is struct{use array:t}',line) + call dcl_type(parser,'matrix(t:matrix_element) is _matrix(array(t,shape2d))',line) + call dcl_type(parser,'vector(t:matrix_element) is _matrix(array(t,shape1d))',line) + call dcl_type(parser,'matrix_template(t:matrix_element) is _matrix(array_template(t,shape2d))',line) + call dcl_type(parser,'vector_template(t:matrix_element) is _matrix(array_template(t,shape1d))',line) + call dcl_uproc(parser,'PM__matrix(x)=new _matrix{array=x}',line) + call dcl_uproc(parser,'vector(x:matrix_element,n:shape1d or extent1d)='//& + 'PM__matrix(array(x,n))',line) + call dcl_uproc(parser,'vvector(x:matrix_element,n:shape1d or extent1d)='//& + 'PM__matrix(varray(x,n))',line) + call dcl_uproc(parser,'dvector(x:matrix_element,n:shape1d or extent1d)='//& + 'PM__matrix(array(x,n,BLOCK_CYCLIC(32)))',line) + call dcl_uproc(parser,'dvvector(x:matrix_element,n:shape1d or extent1d)='//& + 'PM__matrix(varray(x,n,BLOCK_CYCLIC(32)))',line) + call dcl_uproc(parser,'vector(x:matrix_element,n:shape1d or extent1d,'//& + 'distr:distr_template,key...)='//& + 'PM__matrix(array(x,n,distr,key...))',line) + call dcl_uproc(parser,'vvector(x:matrix_element,n:shape1d or extent1d,'//& + 'distr:distr_template,key...)='//& + 'PM__matrix(varray(x,n,key...))',line) + call dcl_uproc(parser,'matrix(x:matrix_element,n:shape2d or extent2d)='//& + 'PM__matrix(array(x,n))',line) + call dcl_uproc(parser,'vmatrix(x:matrix_element,n:shape2d or extent2d)='//& + 'PM__matrix(varray(x,n))',line) + call dcl_uproc(parser,'dmatrix(x:matrix_element,n:shape2d or extent2d)='//& + 'PM__matrix(array(x,n,BLOCK_CYCLIC(32)))',line) + call dcl_uproc(parser,'dvmatrix(x:matrix_element,n:shape2d or extent2d)='//& + 'PM__matrix(varray(x,n,BLOCK_CYCLIC(32)))',line) + call dcl_uproc(parser,'matrix(x:matrix_element,n:shape2d or extent2d,'//& + 'distr:distr_template,key...)='//& + 'PM__matrix(array(x,n,distr,key...))',line) + call dcl_uproc(parser,'vmatrix(x:matrix_element,n:shape2d or extent2d,'//& + 'distr:distr_template,key...)='//& + 'PM__matrix(varray(x,n,key...))',line) + + call dcl_uproc(parser,'matrix_element_zero(x:num)=convert(0,x)',line) + call dcl_uproc(parser,'matrix_element_balance(x:num,y:num)=xx,yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,'matrix_element_add(x:num,y:num)=x+y',line) + call dcl_uproc(parser,'matrix_element_subtract(x:num,y:num)=x-y',line) + call dcl_uproc(parser,'matrix_element_multiply(x:num,y:num)=x*y',line) + call dcl_uproc(parser,'matrix_element_zero(x:bool)=false',line) + call dcl_uproc(parser,'matrix_element_balance(x:bool,y:bool)=x,y',line) + call dcl_uproc(parser,'matrix_element_add(x:bool,y:bool)=x or y',line) + call dcl_uproc(parser,'matrix_element_multiply(x:bool,y:bool)=x and y',line) + + call dcl_uproc(parser,'+(x:matrix,y:matrix) {'//& + 'check_conform(x.array,y.array);'//& + 'test "Cannot add zero size matrices"=>size(x)>0;'//& + 'var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& + 'for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_add(xx,yy) '//& + 'return z }',line) + + call dcl_uproc(parser,'-(x:matrix,y:matrix) {'//& + 'check_conform(x.array,y.array);'//& + 'test "Cannot add zero size matrices"=>size(x)>0;'//& + 'var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& + 'for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_subtract(xx,yy) '//& + 'return z }',line) + + call dcl_uproc(parser,'*(x:matrix,y:matrix) {'//& + 'sx=#x;sy=#y;sz=[sx.1,sy.2];test "Matrices do not conform for multiplication"=>size(sx.2)==size(sy.1);'//& + 'test "Cannot multiply zero size matrices"=>size(x)>0 and size(y)>0;'//& + 'var z=matrix(b,sz) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& + 'for *i in sz,zz in z.array {'//& + 'var s=matrix_element_zero(_arb(z.array));'//& + 'foreach invar k in #(sx.1) {'//& + ' s=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2]))'//& + '};zz=s};'//& + 'return z }',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// DISTRIBUTED SHAPE (DSHAPE)' +write(*,'(a)') '// *****************************************' + + call dcl_type(parser,'_distrb(extent:extent,dist:distr or null)',line) + call dcl_type(parser,'_distrb(extent:extent,dist:distr) is ...,dshape(extent,dist)',line) + call dcl_type(parser,'_distrb(extent:extent,dist:null) is ...,mshape(extent)',line) + call dcl_type(parser,'shape(extent:extent,dist:distr or null) is _distrb(extent,dist)',line) + call dcl_type(parser,'shape1d(extent:extent1d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'shape2d(extent:extent2d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'shape3d(extent:extent3d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'shape4d(extent:extent4d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'shape5d(extent:extent5d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'shape6d(extent:extent6d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'shape7d(extent:extent7d,dist:distr or null) is shape(extent,dist)',line) + call dcl_type(parser,'PM__distr_tag is unique',line) + + call dcl_type(parser,'dshape(extent:extent,dist:distr) '//& + 'is rec {use _mshape:mshape(extent),dist:dist,_tile,'//& + '_tilesz,_size:int,_level:int,_dtag:PM__distr_tag}',line) + call dcl_uproc(parser,& + 'check_conform(x:dshape,y:mshape) { check_conform(x._mshape,y) }',line) + call dcl_uproc(parser,& + 'check_conform(x:mshape,y:dshape) { '//& + ' test "A distributed object connot conform to a non-distributed value" => ''false'//& + '}',line) + call dcl_uproc(parser,& + 'check_conform(x:dshape,y:dshape) { '//& + ' check_conform(x._mshape,y._mshape);'//& + ' test "Objects have different distributions"=>'//& + ' x.dist==y.dist }',line) + call dcl_uproc(parser,'conform(x:dshape,y:mshape)=conform(x._mshape,y)',line) + call dcl_uproc(parser,'conform(x:mshape,y:dshape)=''false',line) + call dcl_uproc(parser,'conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist',line) + call dcl_uproc(parser,'_local_size(x:dshape)=size(x._tile)',line) + +write(*,'(a)') '// Get an element from a null tile - just pass index through' + call dcl_uproc(parser,'element(x:null,y:tuple(index))=y',line) + call dcl_uproc(parser,'element(x:null,y:int)=y',line) + + call dcl_uproc(parser,'size(d:dshape)=d._size',line) + call dcl_uproc(parser,'dims(d:dshape)=dims(d._mshape._extent)',line) + call dcl_uproc(parser,'#(d:dshape)=new dshape{_mshape=#d._mshape,'//& + 'dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,'//& + '_level=d._level,_dtag=d._dtag}',line) + call dcl_uproc(parser,'[](d:dshape,s:index)=d._mshape._extent[s]',line) + call dcl_uproc(parser,'[](d:dshape,s:subs)=_dshape_slice(d,ss)'//& + ' where ss=fill_in(#d._mshape._extent,s,''true){'//& + ' check_contains(#(d._mshape._extent),s)}',line) + call dcl_uproc(parser,'_dshape_slice(d:dshape,ss)=new dshape{_mshape=shape(#active_dims(ss)),'//& + 'dist=dist,_tile=tile,_tilesz=#tile,_size=size(tile),'//& + '_level=d._level,_dtag=d._dtag} where tile=element(dist,_shrd_node())'//& + ' where dist=sliced_distr(d.dist,ss)',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// DISTRIBUTED ARRAY AND SHAPE TEMPLATES' +write(*,'(a)') '// *****************************************' + + call dcl_type(parser,'darray_template(e,d,p,t) is '//& + 'rec {_e:e,_d:d,_p:p,_t:t,_v}',line) + + call dcl_type(parser,'dshape_template(d,p,t) is '//& + 'rec {_d:d,_p:p,_t:t}',line) + + call dcl_uproc(parser,'darray(e,d:extent)=array(e,d,VBLOCK)',line) + + call dcl_uproc(parser,'array(e,d:extent,'//& + 'distr:distr_template,topo:any=null)='//& + 'new darray_template {_e=e,_d=d,_p=distr,_t=topo,_v=''true}',line) + + call dcl_uproc(parser,'array(e,d:extent,distr:null or tuple(null))=array(e,d)',line) + + call dcl_uproc(parser,'dvarray(e,d:extent)=varray(e,d,VBLOCK)',line) + + call dcl_uproc(parser,'varray(e,d:extent,'//& + 'distr:distr_template,topo:any=null)='//& + 'new darray_template {_e=e,_d=d,_p=distr,_t=topo,_v=''true}',line) + + call dcl_uproc(parser,'varray(e,d:extent,distr:null or tuple(null))=varray(e,d)',line) + + call dcl_uproc(parser,'shape(d:extent,'//& + 'distr,topo:any=null)='//& + 'new dshape_template {_d=d,_p=distr,_t=topo}',line) + + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// DISTRIBUTED ARRAYS' +write(*,'(a)') '// *****************************************' + + call dcl_uproc(parser,& + 'PM__dup(d:darray_template) { '//& + ' dd=dims(d._d);'//& + ' topo=topology(d._t,d._p,dd,'//& + ' min(size(d._d),shrd_nnode()));'//& + ' dist=distribute(d._p,dd,topo);'//& + ' test "Not enough processors to implement distribution"=>'//& + ' size(#dist)<=shrd_nnode();'//& + ' p=_shrd_node();'//& + ' var elem=empty(dist);'//& + ' if p'//& + ' size(#dist)<=shrd_nnode();'//& + ' p=_shrd_node();'//& + ' var elem=empty(dist);'//& + ' if p ''false',line) + + call dcl_uproc(parser,'_arb(dd:any^dshape)=_get_aelem(dd,0)',line) + call dcl_uproc(parser,& + 'dims(dd:any^dshape)=dims((#dd)._mshape)',line) + + call dcl_uproc(parser,'PM__redim(a,d)=_redim(a,d)',line) + call dcl_uproc(parser,'PM__local(a:any^dshape)=_redim(a,(#a)._tilesz)',line) + call dcl_uproc(parser,'PM__local(a:any^mshape)=a',line) + call dcl_uproc(parser,'PM__local%(x:shared) shared =PM__local(x)',line) + call dcl_uproc(parser,'element(a:any^dshape,t) { '//& + 'p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& + 'var r=_arb(a);if p==_this_node():r=_get_aelem(a,i);_bcast_shared(&r,p);return r} ',line) + call dcl_uproc(parser,'_set_elem(&a:any^dshape,v,t) {'//& + ' p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& + ' if p==_this_node():PM__setaelem(&a,i,v)}',line) + + + +write(*,'(a)') '// *************************************************' +WRITE(*,'(A)') '// SLICES' +write(*,'(a)') '// *************************************************' + +write(*,'(a)') '// Slices' + call dcl_type(parser,'array_slice(a,s) is struct^{_a:a,_s:s}',line) + call dcl_uproc(parser,'_arb(x:array_slice)=_arb(x._a)',line) + call dcl_uproc(parser,'#(x:array_slice)=#(x._s)',line) + call dcl_uproc(parser,'#(x:array_slice(any^dshape))=_dshape_slice(d,d._mshape._extent#x._s) where d=#(x._a)',line) + call dcl_uproc(parser,'conform(x:mshape,y:array_slice)='//& + 'map_reduce($_conform,$and,x,y._s)',line) + call dcl_uproc(parser,'conform(x:dshape,y:array_slice)='//& + 'map_reduce($_conform,$and,x._mshape,y._s)',line) + call dcl_uproc(parser,'conform(x,y:array_slice)='//& + 'map_reduce($_conform,$and,#x,y._s)',line) + call dcl_uproc(parser,'dims(x:array_slice)=dims(x._s)',line) + call dcl_uproc(parser,'size(x:array_slice)=size(x._s)',line) + call dcl_uproc(parser,'element(x:array_slice(any^mshape,),y:index)=element(x._a,x._s[y])',line) + call dcl_uproc(parser,'element(x:array_slice,y:subs)=new array_slice {_a=x._a,_s=x._s[y]}',line) + call dcl_uproc(parser,'_set_elem(&x:array_slice(any^mshape,),v,y:index)'//& + ' {PM__setaelem(&^(x._a),index(#(x._a),x._s[y]),v)}',line) + call dcl_uproc(parser,'PM__dup(x:array_slice(any^mshape,))'//& + '{var a=array(_arb(x),#x);a=x;return a}',line) + call dcl_uproc(parser,'PM__dup(x:array_slice(any^dshape,))'//& + '{d=#x._a;ss=(#x._a)._mshape#x._s;var a=array(_arb(x._a),_dshape_slice(d,ss));'//& + '_set_slice(&^(PM__local(a)),#(#a)._tile,'//& + ' PM__local(x._a),overlap((#x._a)._tile,ss));'//& + 'return a}',line) + +write(*,'(a)') '// *************************************************' +WRITE(*,'(A)') '// ARRAY & SLICE ASSIGNMENT' +write(*,'(a)') '// *************************************************' + + call dcl_uproc(parser,'PM__assign(&xx:farray,x:any)'//& + ' {check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) + call dcl_uproc(parser,'PM__assign(&xx:farray,x:array) '//& + '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& + line) + call dcl_uproc(parser,'PM__assign(&xx:varray,x:any except varray)'//& + ' {check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) + call dcl_uproc(parser,'PM__assign(&xx:varray,x:farray) '//& + '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& + line) + call dcl_uproc(parser,'PM__assign_var(&xx:farray,x:any)'//& + ' {check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) + call dcl_uproc(parser,'PM__assign_var(&xx:farray,x:array) '//& + '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& + line) + call dcl_uproc(parser,'PM__assign_var(&xx:varray,x:any except varray)'//& + ' {check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) + call dcl_uproc(parser,'PM__assign_var(&xx:varray,x:farray) '//& + '{_array_assign(&xx,x,same_type(_arb(x),_arb(xx)))}',& + line) + call dcl_uproc(parser,'PM__aliased_assign(&xx,x){}',line) + call dcl_uproc(parser,'PM__aliased_assign(&xx:array_slice,x:array_slice) <> {'//& + '_assign_internal_slice(&xx,x._s)}',line) + + call dcl_uproc(parser,'_array_assign(&xx,x,v:''false)'//& + '{check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) + call dcl_uproc(parser,'_array_assign(&xx,x,v:''true)'//& + '{check_conform(extent(#xx),extent(#x));'//& + 'if _copy_array(&xx,x):_sync_messages(xx,x)}',line) + call dcl_uproc(parser,'_array_assign(&xx:array_slice,x:array_slice,v:''true)'//& + '{check_conform(extent(#xx),extent(#x));'//& + 'if _copy_array(&xx,x):_sync_messages(xx,x)}',line) + call dcl_uproc(parser,'_array_assign(&xx:varray,x,v:''true) '//& + '{_assign_element(&xx,x)}',line) + call dcl_uproc(parser,'_array_assign(&xx:varray,x:array_template,v:''true) '//& + '{_assign_element(&xx,PM__dup(x))}',line) + + + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'_set_slice(&x,a,y,b) {foreach i in a,j in b:x[i]=y[j]}',line) +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,'_set_slice(&x,a,y,b) {'//& + 'if size(a)>0:forall i in a,j in b{sync x[i]=y[j]}}',line) +write(*,'(a)') 'PM__endif' + + call dcl_type(parser,'_non_d is any^mshape,array_slice(any^mshape,)',line) + + call dcl_uproc(parser,'_set_array(&x:any^mshape,y)'//& + '{forall i in x { _assign(&i,y) } } ',line) + call dcl_uproc(parser,'_set_array(&x:any^dshape,y)'//& + '{_set_array(&^(PM__local(^(&x))),y)}',line) + call dcl_uproc(parser,'_set_array(&x:array_slice(any^mshape,),y)'//& + '{forall i in x._s {_set_elem(&x._a,y,i <>) }}',line) + call dcl_uproc(parser,'_set_array(&x:array_slice(any^dshape,),y){'//& + 'tile=(#x._a)._tile;'//& + 't=overlap(tile,((#x._a)#x._s));'//& + 'forall i in t { '//& + ' _set_elem(&x._a,y,i <>) '//& + '}}',line) + + call dcl_uproc(parser,'_copy_array(&a:_non_d,b:_non_d)'//& + '{forall i in a, j in b {i=j};return ''false}',line) + + call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:_non_d) {'//& + 'tile=(#xx)._tile;'//& + 'forall i in tile {PM__setaelem(&xx,'//& + 'index(dims(tile),here),x[(#x)[i]] <>)};return ''false }',& + line) + + call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:_non_d) {'//& + 'tile=(#xx._a)._tile;subtile,subarray=overlap(tile,(#xx._a)._mshape#xx._s);'//& + 'forall i in subtile,j in subarray {'//& + ' PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <>) };return ''false }',& + line) + + call dcl_uproc(parser,'_copy_array(&a:_non_d,x:any^dshape) {'//& + ' dist=(#x).dist; '//& + ' foreach p in #(dist) {'//& + ' tile=element(dist,p);'//& + ' i=index(dims(dist),p);'//& + ' if i==_shrd_node() { '//& + ' forall kk in PM__local(x),j in tile { '//& + ' var k=kk;_bcast_shared(&k,i);'//& + ' _set_elem(&a,k,(#a)[j] <>)'//& + ' }'//& + ' } else { '//& + ' forall j in tile { '//& + ' var k=_arb(a);'//& + ' _bcast_shared(&k,i);'//& + ' _set_elem(&a,k,(#a)[j] <>);'//& + ' }'//& + ' }'//& + ' };return ''false}',& + line) + + call dcl_uproc(parser,'_copy_array(&v:_non_d,x:array_slice(any^dshape,)) {'//& + ' dist=(#(x._a)).dist;xs=(#(x._a))._mshape#x._s;'//& + ' nodes=#dist;'//& + ' foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) {'//& + ' p=nodes[pp];utile,elem=overlap(dist[nodes[p]],xs);'//& + ' i=index(dims(dist),p);'//& + ' if i==_shrd_node() {'//& + ' forall j in utile, jj in elem { '//& + ' var k=element(PM__local(x._a),j); '//& + ' _bcast_shared(&k,i);'//& + ' _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>)'//& + ' }'//& + ' } else { '//& + ' forall j in elem {'//& + ' var k=_arb(x._a);'//& + ' _bcast_shared(&k,i);'//& + ' _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>)'//& + ' }'//& + ' }'//& + ' };return ''false}',& + line) + + call dcl_uproc(parser,'_copy_array(&x:any^mshape,y:array_template) '//& + '{_set_array(&x,y._a);return ''false }',line) + call dcl_uproc(parser,'_copy_array(&x:any^dshape,y:array_template) {'//& + '_set_array(&^(PM__local(^(&x))),y._a);return ''false}',line) + + call dcl_type(parser,'_comp is contains(array or *any or ^*(,,,,))',line) + + call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s,'//& + ' PM__local(x._a),xd,xd._mshape#x._s,xd._tile)'//& + ' where xxd=#(xx._a),xd=#(x._a);return ''true}',line) + call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:array_slice(any^dshape)) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent),'//& + ' PM__local(x._a),xd,xd._mshape#x._s,xd._tile)'//& + ' where xxd=#xx,xd=#(x._a);return ''true}',line) + call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:any^dshape) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s,'//& + ' PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile)'//& + ' where xxd=#(xx._a),xd=#x;return ''true}',line) + call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:any^dshape) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent),'//& + ' PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile)'//& + ' where xxd=#xx,xd=#x;return ''true}',line) + + call dcl_uproc(parser,'_assign_internal_slice(&xx:array_slice(any^mshape),s) {'//& + 'x=new array_slice{_a=xx._a,_s=s};xx=x}',line) + call dcl_uproc(parser,'_assign_internal_slice(&xx:array_slice(any^dshape),s) {'//& + 'xxd=#(xx._a);xxs=xxd._mshape#xx._s;xs=xxd._mshape#s;ltile=intersect(xxd._tile,xs);ls=#ltile;'//& + 'var x=array(_arb(xx),ls);_set_slice(&x,ls,PM__local(xx._a),overlap(xxd._tile,ltile));'//& + '_copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxs,'//& + ' x,xxd,xxd._mshape#s,ltile)}',line) + +!!$ call dcl_uproc(parser,'_copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) {'//& +!!$ 'print_all(_sys_node()++"copy");_push_node_dist();'//& +!!$ 'oldpart,oldtile=overlap(xs,oldd._tile);'//& +!!$ 'newpart,newtile=overlap(xxs,newd._tile);'//& +!!$ 'print(_sys_node()++"R"++nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))));'//& +!!$ 'if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) {'//& +!!$ ' print("$$$$");'//& +!!$ ' p=index(dims(oldd.dist),pp);'//& +!!$ ' if p/=_this_node() {'//& +!!$ ' tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p))));'//& +!!$ ' ov=overlap(newd._tile,tile);print_all(_sys_node()++"recv"++size(ov)++"$"++p);'//& +!!$ ' if size(ov)>0:_recv_slice(p,&xx,ov)}'//& +!!$ '};'//& +!!$ 'print(_sys_node()++"xx"++xxs++xs);'//& +!!$ 'print(_sys_node()++"send consider"++xxs++element(xxs,active_dims(xs,oldpart))++xs);'//& +!!$ 'print(_sys_node()++"send too"++nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))));'//& +!!$ 'print(_sys_node()++"node"++_shrd_node()++"£"++_this_node());'//& +!!$ 'if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) {'//& +!!$ ' p=index(dims(newd.dist),pp);'//& +!!$ ' if p/=_this_node() {'//& +!!$ ' tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p))));'//& +!!$ ' ov=overlap(otile,tile);print_all(_sys_node()++"send"++size(ov)++"$"++p);if size(ov)>0:_send_slice(p,x,ov);'//& +!!$ 'print(_sys_node()++"sent")}};'//& +!!$ 'if size(newpart)>0 and size(oldpart)>0 {print(_sys_node()++"%"++newpart++oldpart);'//& +!!$ 'oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart));'//& +!!$ '_set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o))'//& +!!$ ';print("sliceset")};PM_pop_node(newd)}',line) + + + call dcl_uproc(parser,'_copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) {'//& + '_push_node_dist();'//& + 'oldpart,oldtile=overlap(xs,oldd._tile);'//& + 'newpart,newtile=overlap(xxs,newd._tile);'//& + 'if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) {'//& + ' p=index(dims(oldd.dist),pp);'//& + ' if p/=_this_node() {'//& + ' tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p))));'//& + ' ov=overlap(newd._tile,tile);'//& + ' if size(ov)>0:_recv_slice(p,&xx,ov)}'//& + '};'//& + 'if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) {'//& + ' p=index(dims(newd.dist),pp);'//& + ' if p/=_this_node() {'//& + ' tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p))));'//& + ' ov=overlap(otile,tile);if size(ov)>0:_send_slice(p,x,ov);'//& + '}};'//& + 'if size(newpart)>0 and size(oldpart)>0 {'//& + 'oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart));'//& + '_set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o))'//& + '};PM_pop_node(newd)}',line) + + + call dcl_uproc(parser,'_copy_darray_slice(&xx:_comp^any,newd,xxs,x,oldd,xs,otile) {'//& + '_push_node_dist();'//& + 'oldpart,oldtile=overlap(xs,oldd._tile);'//& + 'newpart,newtile=overlap(xxs,newd._tile);'//& + 'if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) {'//& + ' p=index(dims(newd.dist),pp);'//& + ' if p/=_this_node() {'//& + ' tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p))));'//& + ' ov=overlap(otile,tile);if size(ov)>0:_send_slice(p,x,ov)}'//& + '};'//& + 'if size(newpart)>0 and size(oldpart)>0 {'//& + 'oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart));'//& + '_set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o))};'//& + 'if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) {'//& + ' p=index(dims(oldd.dist),pp);'//& + ' if p/=_this_node() {'//& + ' tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p))));'//& + ' ov=overlap(newd._tile,tile);'//& + ' if size(ov)>0:_recv_slice_sync(p,&xx,ov)}'//& + '};'//& + 'PM_pop_node(newd)}',line) + + call dcl_uproc(parser,'_xp(x:single_point,y)=single_point(low(y))',line) + call dcl_uproc(parser,'_xp(x,y)=y',line) + +write(*,'(a)') '// *************************************************' +WRITE(*,'(A)') '// REFERENCES (SUBSCRIPTS AND SLICES)' +write(*,'(a)') '// *************************************************' + +write(*,'(a)') '// Reference type for & args' + call dcl_type(parser,'PM__reftype(x) is x,^shared(x,,,,)',line) + +write(*,'(a)') '// Support for internal ^(...) reference type' + call dcl_proc(parser,'_v1(x:any)->PM__d1 x',"elem",1,line,0) + call dcl_proc(parser,'_v2(x:any)->PM__d2 x',"elem",2,line,0) + call dcl_proc(parser,'_v3(x:any)->PM__d3 x',"elem",3,line,0) + call dcl_proc(parser,'_v4(x:any)->PM__d4 x',"elem",4,line,0) + call dcl_proc(parser,'_v5(x:any)->PM__d5 x',"elem",5,line,0) + + call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->PM__d1% x',"elem",1,line,0) + call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->PM__d2% x',"elem",2,line,0) + call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->PM__d3% x',"elem",3,line,0) + call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->PM__d4% x',"elem",4,line,0) + call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->PM__d5% x',"elem",5,line,0) + +write(*,'(a)') '// Right hand side references' + call dcl_uproc(parser,'_make_null(x)=null',line) + call dcl_uproc(parser,& + 'PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) + call dcl_uproc(parser,'PM__subref(x,t:subs)'//& + '{tt=_tup(t);check_contains(#x,tt);return _subref(x,tt) }',line) + call dcl_uproc(parser,'PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x))',line) + call dcl_uproc(parser,'PM__subref(x:^*(,,,,),t:null)='//& + 'PM__subref(x,map($_make_null,#_v1(x)))',line) + call dcl_uproc(parser,'_subref(x:any^mshape,t:index)=element(x,t)',line) + call dcl_uproc(parser,'_subref(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t,''true)}',line) + call dcl_uproc(parser,'_subref(x:array_slice(any^mshape,),t:index)=element(x._a,x._s[t])',line) + call dcl_uproc(parser,'_subref(x:array_slice,t:subs)=new array_slice {_a=x._a,_s=x._s[t]}',line) + call dcl_uproc(parser,'_subref(x:any^dshape,t:index)='//& + ' PM__ref(_arb(x),x,i,p,_s_ref)'//& + ' where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t))',line) + call dcl_uproc(parser,'_subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t])',line) + call dcl_uproc(parser,'_subref(a:^*(,,,,),t)='//& + 'PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a))',line) + call dcl_uproc(parser,'_subref(a,t)=$[](a,t)',line) + call dcl_uproc(parser,'[](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...)))',line) + +write(*,'(a)') '// Left hand side references' + call dcl_uproc(parser,& + 'PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) + call dcl_uproc(parser,'PM__sublhsamp(x,t:subs)'//& + ' {tt=_tup(t);check_contains(#x,tt);return _sublhs(x,tt)}',line) + call dcl_uproc(parser,'PM__sublhsamp(x:any^dshape,t:subs)'//& + ' {test "Cannot have subscript of a distributed array in ""&"" argument"=>''false;'//& + ' return _arb(x)}',line) + call dcl_uproc(parser,& + 'PM__sublhs(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) + call dcl_uproc(parser,'PM__sublhs(x,t:subs)'//& + ' {tt=_tup(t);check_contains(#x,tt);return _sublhs(x,tt)}',line) + call dcl_uproc(parser,'PM__sublhs(x:^!(,,,,),t:subs)'//& + ' {tt=_tup(t);return _sublhs(x,tt)}',line) + call dcl_uproc(parser,& + 'PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x))',line) + call dcl_uproc(parser,'PM__sublhs(x:^!(,,,,),t:null)='//& + 'PM__sublhs(x,map($_make_null,#_v1(x)))',line) + call dcl_uproc(parser,'_sublhs(x:any^mshape,t:index)=_make_subref(x,t)',line) + call dcl_uproc(parser,& + '_sublhs(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t,''true)}',line) + call dcl_uproc(parser,'_sublhs(x:array_slice(any^mshape,),t:index)='//& + '_make_subref(x._a,x._s[t])',line) + call dcl_uproc(parser,'_sublhs(x:array_slice,t:subs)='//& + 'new array_slice {_a=x._a,_s=x._s[t]}',line) + call dcl_uproc(parser,'_sublhs(x:any^dshape,t:index)='//& + ' PM__ref(_arb(x),x,i,p,_s_ref)'//& + ' where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t))',line) + call dcl_uproc(parser,'_sublhs(a:^!(,,,,),t)='//& + 'PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a))',line) + call dcl_uproc(parser,'[](&a:array,v,arg...)'//& + '{ PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v)}',line) + +write(*,'(a)') '// Realise a reference' + call dcl_uproc(parser,'PM__valref(x)=x',line) + call dcl_uproc(parser,'PM__valref(x:^*(,,,,)) {'//& + ' var v=_v1(x);if _v4(x)==_shrd_node() { v=_getref(x,null)};'//& + ' _bcast_shared(&v,_v4(x));return v }',line) +!write(*,'(a)') '// call dcl_uproc(parser,'PM__getref(x:^!(,,,,))=PM__valref(x)',line)' + +write(*,'(a)') '// Assign to a reference' + call dcl_uproc(parser,'PM__assign(&x:^*(,,,,),y) {'//& + 'check_assign_types(_v1(^(&x)),y);'//& + 'if _v4(^(&x))==_shrd_node() { PM__assign(&^(_getlhs(^(&x),null)),y) }}',line) + call dcl_uproc(parser,'PM__assign(&x:^*(,,,,),y,p:assignment_operator) {'//& + 'if _v4(^(&x))==_shrd_node() { PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) }}',line) + +write(*,'(a)') '// *************************************************************' +WRITE(*,'(A)') '// DISTRIBUTED REFERENCES' +write(*,'(a)') '// *************************************************************' + +write(*,'(a)') '// Distributed reference is an internal compiler type' +write(*,'(a)') '// ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode)' +write(*,'(a)') '// mode is:' +write(*,'(a)') '// null -- local reference' +write(*,'(a)') '// _s_ref -- shrd index on darray, only shrd/indexed otherwise' +write(*,'(a)') '// _sp_ref -- shrd index on darray, some priv after (or before)' +write(*,'(a)') '// _d_ref -- indexed index on darray, shrd/indexed otherwise' +write(*,'(a)') '// _dp_ref -- indexed index on darray, some priv after (or before)' +write(*,'(a)') '// _p_ref -- priv index on darray and possibly elsewhere' + + call dcl_type(parser,'_s_ref is unique',line) + call dcl_type(parser,'_sp_ref is unique',line) + call dcl_type(parser,'_d_ref is unique',line) + call dcl_type(parser,'_dp_ref is unique',line) + call dcl_type(parser,'_p_ref is unique',line) + + call dcl_proc(parser,& + '_import_dref%(r:any,s:any,h:any,x:any)->^^x',"import_dref",0,line,0) + +write(*,'(a)') '// Some trivial referencing cases' + call dcl_uproc(parser,'PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t)',line) + call dcl_uproc(parser,'PM__sublhsamp%(x:any^dshape,t:subs)'//& + ' {test "Cannot have subscript of a distributed array in ""&"" argument"=>''false;'//& + ' return _arb(x)}',line) + call dcl_uproc(parser,'PM__sublhs%(x,y)=PM__subref%(x,y)',line) + call dcl_uproc(parser,'PM__sublhs%(x:priv ^*(,,,,),y)=PM__subref%(x,y)',line) + call dcl_uproc(parser,'PM__sublhs%(x:priv,y)=PM__sublhs(x,y):'//& + 'test """sync"" assignment updating a private variable"=>''false',line) + call dcl_uproc(parser,'PM__subref%(x:priv,y)=PM__subref(x,y)',line) + call dcl_uproc(parser,'PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y)',line) + call dcl_uproc(parser,'PM__subref%(x:priv,y:invar indexed)=PM__subref(x,*y)',line) + call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^mshape,y:index)=PM__subref(x,y)',line) + call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^mshape,y:subs)=PM__subref(x,y)',line) + call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^mshape,y:invar indexed)='//& + 'PM__subref(x,_dmap(y,here))',line) + call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):'//& + 'test """sync"" assignment updating a private variable"=>''false',line) + call dcl_uproc(parser,'PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y)',line) +!!$ call dcl_uproc(parser,'PM__subref%(region:mshape,x:any^dshape,y)=_arb(x)'//& +!!$ ':test "Cannot subscript distributed array in ""forall""" => ''false',line) +!!$ call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^dshape,y:invar indexed)='//& +!!$ '_arb(x)'//& +!!$ ':test "Cannot subscript distributed array in ""forall""" => ''false',line) + call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y)',line) + call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y))',line) + + +write(*,'(a)') '// Reference of non-distributed array with priv or indexed subscript' + call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:index)'//& + '{tt=_tup(t);check_contains(#x,tt);i=index(#x,tt);'//& + 'return PM__dref(_get_aelem(x,i),x,i,null,null)}',line) + call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:subs)'//& + '{tt=_tup(t);check_contains(#x,tt);return PM__drefs(x,x,tt,null,null)}',line) + call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:invar indexed)='//& + 'PM__subref%(x,_dmap(t,here))',line) + call dcl_uproc(parser,& + 'PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t])',line) + call dcl_uproc(parser,'PM__subref%(x,t)='//& + 'PM__dref($[](x,t),x,t,null,null)',line) + +write(*,'(a)') '// Subscript or slice of distributed array' + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) complete <>'//& + '{tt=_tup(t);check_contains(#(x),tt);'//& + 'return PM__dref(_arb(x),x,i,p,_s_ref) '//& + 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:index)'//& + '{tt=_tup(t);check_contains(#(x),tt);'//& + 'return PM__dref(_arb(x),x,i,p,_p_ref) '//& + 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:subs)'//& + '{tt=_tup(t);check_contains(#(x),tt);var xx=varray(_arb(x),empty(#x));'//& + 'return PM__drefs(xx,x,tt,p,_p_ref) '//& + 'where p=nodes_for_grid((#x).dist,tt)}',line) + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t)',line) + call dcl_uproc(parser,& + 'PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond {'//& + 'check_contains(#x,_dmap(t,here));'//& + 'return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t)}',line) + call dcl_uproc(parser,& + 'PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t)',line) + +write(*,'(a)') '// Subscript or slice of non-distristuted array which is itself result of variant slice' + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index)'//& + '{tt=_tup(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt)'//& + 'return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null)}',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){'//& + 'tt=_tup%(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& + 'return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null)}',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) {'//& + 'tt=_tup(t);check_contains(#(_v1%(x)),tt);'//& + 'return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null)}',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)='//& + 'PM__subref%(x,_dmap(t,here))',line) + +write(*,'(a)') '// Subscript or slice of darray which is itself the result of a priv subscript' + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index)'//& + '{tt=_tup(t);check_contains(#_v1%(x),tt);'//& + 'return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) '//& + 'where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt)}',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:subs)'//& + '{tt=_tup(t);check_contains(#_v1%(x),tt);'//& + 'return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) '//& + 'where p=nodes_for_grid((#_v1%(x)).dist,tt)}',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)='//& + 'PM__subref%(x,_dmap(t,here))',line) + +write(*,'(a)') '// Subscript of a priv slice' + call dcl_uproc(parser,'PM__subref%(x:priv ^#(,,,null,null),t:subs)='//& + 'PM__subref%(_v2%(x),_v3%(x)[_tup(t)])',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)='//& + 'PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here)',line) + +write(*,'(a)') '// Subscript of distributed reference' + call dcl_uproc(parser,'_arb%(x:partial)=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:complete) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:chan) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:invar) complete <>=_arb(x)',line) + + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)='//& + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)='//& + 'PM__dref(_arb%(_v1%(x)),x,_tup(t))',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)='//& + 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref)',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar indexed)='//& + 'PM__subref%(x,_dmap(_tup(t),here))',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:invar indexed)='//& + 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)='//& + 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)='//& + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) + call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)='//& + 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref)',line) + +write(*,'(a)') '// Node .[] subscript of distributed array' + call dcl_type(parser,'_lcl is unique{_LCL}',line) + call dcl_uproc(parser,'PM__nodelhs%(x,y)=PM__noderef%(x,y)',line) + call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)='//& + '^(PM__import_val(PM__local(x)),coherent)',line) + call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:invar any_int){'//& + 'xd=#((#x).dist);check_contains(xd,y);'//& + 'return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)'//& + 'where p=index(xd,int(y))}',line) + call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:priv any_int){'//& + 'xd=#((#x).dist);check_contains(xd,y);'//& + 'return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)'//& + 'where p=index(xd,y)}',line) + call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:shared indexed)='//& + 'PM__noderef%(x,*y)',line) + call dcl_uproc(parser,'PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:invar any_int){'//& + 'xd=#((#x).dist);check_contains(xd,y);'//& + 'return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)'//& + 'where p=index(xd,int(y))}',line) + call dcl_uproc(parser,'PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:priv any_int){'//& + 'xd=#((#x).dist);check_contains(xd,y);'//& + 'return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)'//& + 'where p=index(xd,int(y))}',line) + call dcl_uproc(parser,'PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:shared indexed)='//& + 'PM__noderef%(x,*y)',line) + call dcl_uproc(parser,'PM__noderef%(x,y)=error_type() {'//& + 'if not region is {'//& + ' test """.[]"" subscript in non-distributed region"=>''false'//& + '} elseif x is {'//& + ' test """.[]"" subscript cannot be applied to a mirrored array"=>''false'//& + '} elseif not x is {'//& + ' test """.[]"" subscript applied to a non-array"=>''false'//& + '} elseif not y is {'//& + ' test """.[]"" subscript must have an integer value"=>''false'//& + '} else {'//& + ' test "Incorrect "".[]"" subscript"=>''false'//& + '}}',line) + +write(*,'(a)') '// May need to cap off reference with here' + call dcl_type(parser,'_here(t) is rec {here:t}',line) + call dcl_uproc(parser,'_cap%(x,h)<>=x',line) + call dcl_uproc(parser,'_cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) + call dcl_uproc(parser,'_capn%(x,h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) + +write(*,'(a)') '// Treat ! variables differently only for limited circumstances in drefs' + call dcl_uproc(parser,'_drat(at,tile,t)=''false',line) + call dcl_uproc(parser,'_drat(at:''true,tile:tuple(range or block_seq),t:indexed and _dr)=''true',line) + call dcl_type(parser,'_di(n) is indexed_dim(''1,''1,,n) or int',line) + call dcl_type(parser,'_dr is [_di(''1)],[_di(''1),_di(''2)],'//& + '[_di(''1),_di(''2),_di(''3)],[_di(''1),_di(''2),_di(''3),_di(''4)],'//& + '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5)],'//& + '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5),_di(''6)],'//& + '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5),_di(''6),_di(''7)]',line) + +write(*,'(a)') '// Resolve a distributed reference' + call dcl_uproc(parser,'PM__getref%(x,at)=x',line) + call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x)',line) + call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,int,_p_ref),at) {'//& + 'PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null);return v}',line) + call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,int,_sp_ref),at) {'//& + 'PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null);return v}',line) + call dcl_uproc(parser,'_scatter(x,region) {'//& + 'if _this_node()==_v4(x):foreach node in #region.dist {'//& + ' d=#region._mshape;a={_getref(_import_dref%(x),j): j in d};'//& + ' p=index(dims(region.dist),node);'//& + ' _send_slice(p,a,region.dist[node])}}',line) + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> {'//& + 'chan var xx=_v1%(x);_getref_s%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) PM__node {'//& + 'PM__head_node{_irecv(_v4(x),&xx)};'//& + '_scatter(x,region);'//& + '_sync_messages(xx,x)}',line) + call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{'//& + 'chan var xx=_v1%(x);_getref_sc%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) PM__node {'//& + '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& + '_sync_messages(xx,x)}',line) + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> {'//& + 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a!))),'//& + '^^(x),at <>);'//& + '_bcast_shared(&a);return a}',line) + call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) PM__node {'//& + '_get_dindex_from_dref(&a,x,t.2,'//& + '_local_region(region._tile,subregion(schedule)),region,t.1,'//& + '_drat(at,region._tile,t.1)) where t=_v4(x)'//& + '}',line) + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> {'//& + 'chan var a=_arb(_v2%(x));'//& + '_getref_dc%(&a!,^^(x),at <>);_bcast_shared(&a);return a}',line) + call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) PM__node {'//& + 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& + '_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) '//& + ' where t=_v4(x)}}',line) + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> {'//& + 'chan var a=_v1%(x);'//& + '_getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& + '_bcast_shared(&a);return a}',line) + call dcl_uproc(parser,'_getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node {'//& + 'PM__head_node{_get_dindex_from_ref(&a,x,t.2,'//& + ' _local_region(region._tile,subregion(schedule)),region,'//& + ' t.1,atq,_drat(at,region._tile,t.1))}'//& + '}',line) + + call dcl_uproc(parser,'PM__getref%(x:priv ^#(,,,,),at) {'//& + 'var v=varray(_arb(_v1%(x)),#_v3%(x));'//& + 'var vv=varray(_arb(_v1%(x)),empty(#_v1%(x)));'//& + 'foreach p in _v4%(x) {'//& + ' dist=(#(_getref(_v2%(x),null))).dist;'//& + ' u=overlap(_v3%(x),dist[p]);'//& + ' ppp=index(dims(dist),p);'//& + ' PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null);'//& + ' v[u]=vvv};return v}',line) + +write(*,'(a)') '// Resolve reference locally (once communicated)' + call dcl_uproc(parser,'_getref_elem(x:any^mshape,i)=_get_aelem(x,i)',line) + call dcl_uproc(parser,& + '_getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i)',line) + call dcl_uproc(parser,& + '_getref(x:^*(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x))',line) + call dcl_uproc(parser,'_getref(x:^*(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here)',line) + call dcl_uproc(parser,'_getref(x:^*(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)]',line) + call dcl_uproc(parser,'_getref(x:^*(,,null,,),y)<>=_getref(_v2(x),y)',line) + call dcl_uproc(parser,'_getref(x:^*(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y))',line) + call dcl_uproc(parser,'_getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x)',line) + call dcl_uproc(parser,'_getref(x:^shared(,null,null,null,null),y)<>=_v1(x)',line) + call dcl_uproc(parser,'_getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x))',line) + call dcl_uproc(parser,'_getslice(x:any^dshape,tt) {t=overlap((#x)._tile,tt);'//& + 'var v=varray(_arb(x),#t);v=PM__local(x)[t];return v}',line) + call dcl_uproc(parser,'_getslice(x:any^mshape,t) {'//& + 'var v=varray(_arb(x),#t);v=x[t];return v}',line) + call dcl_uproc(parser,'_getref(x:any^any,y)=x',line) + call dcl_uproc(parser,'_getref(x:^shared(,,indexed,,),y)<>='//& + '_getref(_v2(x),y)[_dmap(_v3(x),y)]',line) + call dcl_uproc(parser,'_getref(x:^shared(,any^dshape,indexed,,),y)<>='//& + 'element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) '//& + 'where ms=#_v2(x)',line) + call dcl_uproc(parser,'_getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) '//& + ':test "Internal error - uncapped dref" => ''false',line) + + + write(*,'(a)') 'PM__if_compiling' + call dcl_proc(parser,'_sync%(any,any,any,&x:any)',"sync",0,line,0) +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,'_sync%(&x:any){}',line) +write(*,'(a)') 'PM__endif' + +write(*,'(a)') '// Assignment of distributed and/or shared or uniform references' + call dcl_uproc(parser,'PM__assign%(&x:priv,y,at) {'//& + '_sync%(&x);PM__assign(&x,y <>)}',line) + call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_sync%(&x);_assign_to_invar%(&x,y) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) complete '//& + '{ PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) shared'//& + '{ PM__assign(&x,y) }',line) + call dcl_uproc(parser,& + '_assign_to_invar%(&x:invar,y:priv) '//& + '{ test "Can only assign an ""invar"" value to an ""invar"" variable" => ''false }',line) + + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) {'//& + 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy)};'//& + 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,''false {'//& + ' test "Cannot assign element twice in same assignment"=>'//& + ' _getref(xx,null)==yy } }',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,at) {'//& + 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y) }}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y,at) {'//& + 'foreach invar p in 0..size(#region.dist)-1 {'//& + ' PM__bcast xx,yy,_cap%(x,here),y,p {'//& + ' PM__assign(&^(_getlhs(^(&xx),null)),yy) }};'//& + 'foreach invar p in 0..size(#region.dist)-1 {'//& + ' PM__bcast xx,yy,_cap%(x,here),y,p {'//& + ' test "Cannot assign an element two different values in a single assignment"=>'//& + ' _getref(xx,null)==yy}}}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y:invar,at) {'//& + '_sync%(&x);var xx=_import_dref%(x);PM__assign(&^(_getlhs(^(&xx),here)),y)}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,at) {'//& + '_sync%(&x);PM__assign(&^(_v1%(^(&x))),y)}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) {'//& + 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy)};'//& + 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,''false '//& + ' { test "Cannot assign element to two different values in same assignment"=>'//& + ' _getref(xx,null)==yy }}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:invar,at) {'//& + 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at '//& + '{ PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y))}}',line) + + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) {'//& + '_set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& + ' $_just_assign,^^(^??),at,_v4(x) <>)}',line) + call dcl_uproc(parser,'_just_assign(x,y)=y',line) + call dcl_uproc(parser,'_set_ref_dp%(&x:invar,y:invar,'//& + ' prc:invar,atq:invar,at:invar,t:invar) PM__node {'//& + '_set_dindex_of_ref(&x,y,t.2,'//& + '_local_region(region._tile,subregion(schedule)),'//& + 'region,t.1,prc,atq,at)'//& + '}',line) + +write(*,'(a)') '// Operater assignment: x =y' + call dcl_uproc(parser,'PM__assign%(&x:priv,y:priv,pr,at) {PM__assign(&x,y,pr)}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv,y:invar,pr,at) {PM__assign(&x,y,pr)}',line) + call dcl_uproc(parser,'PM__assign%(&x:invar,y,pr,at) { _assign_to_invar%(&x,y,pr,at) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete'//& + '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared '//& + '{ PM__assign(&x,y,pr) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:invar,y:priv,pr,at){'//& + '_assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at)}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) {'//& + 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,pr,at) {'//& + 'PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr) }}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) {'//& + 'foreach invar p in 0..size(region.dist)-1 {'//& + ' PM__bcast xx,yy,_cap%(x,here),y,p {'//& + ' PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) }}}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,null,null),y:invar,pr,at) {'//& + 'var xx=_import_dref%(x);PM__assign(&^(_getlhs(^(&xx),here)),y,pr)}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,pr,at) {'//& + 'PM__assign(&^(_v1%(^(&x))),y,pr)}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:priv,pr,at) {'//& + 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) {'//& + 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr)}}',line) + call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) {'//& + '_set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& + '_local_region(region._tile,subregion(schedule)),'//& + 'region,t.1,pr,^^(^??),at <>)'//& + 'where t=_v4%(x)}',line) + +write(*,'(a)') '// Resolve LHS reference (locally after communication)' + call dcl_uproc(parser,'_getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here)',line) + call dcl_uproc(parser,'_getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y)',line) + call dcl_uproc(parser,'_getlhs(x:^(,,int,,),y)='//& + '_make_subref(_getlhs(_v2(x),y),int(_v3(x)))',line) + call dcl_uproc(parser,'_getlhs(x:^shared(,,null,,),y)=_getlhs(_v2(x),y)',line) + call dcl_uproc(parser,'_getlhs(x:^shared(,,int,,),y)='//& + '_make_subref(_getlhs(_v2(x),y),int(_v3(x)))',line) + call dcl_uproc(parser,'_getlhs(x:^(,,subs,,),y)='//& + 'PM__sublhs(_getlhs(_v2(x),y),_v3(x))',line) + call dcl_uproc(parser,'_getlhs(x:^shared(,,subs,,),y)='//& + 'PM__sublhs(_getlhs(_v2(x),y),_v3(x)) ',line) + call dcl_uproc(parser,& + '_local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t))',line) + call dcl_uproc(parser,'_getlhs(x:^#(,,subs,,),y)<>=_local_ref(x,_v3(x))',line) + call dcl_uproc(parser,'_getlhs(x:^#shared(,,subs,,),y)<>=_local_ref(x,_v3(x))',line) + call dcl_uproc(parser,'_getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x)',line) + call dcl_uproc(parser,'_getlhs(x:^shared(,null,null,null,null),y)<>=_v1(x)',line) + call dcl_uproc(parser,'_getlhs(x:^(,null,null,null,null),y)<>=_v1(x)',line) + call dcl_uproc(parser,'_getlhs(x:any^any,y)=x',line) + call dcl_uproc(parser,'_getlhs(x:any^dshape,y)=PM__local(x)',line) + call dcl_uproc(parser,'_getlhs(x:^shared(,,indexed,,),y)<>='//& + '_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y))',line) + call dcl_uproc(parser,'_getlhs(x:^shared(,any^dshape,indexed,,),y)<>='//& + '_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) '//& + 'where ms=#_v2(x)',line) + + call dcl_uproc(parser,'_getlhs(x:^shared(,,indexed,,),y:null)='//& + '_v1(x) :test "Internal error -- uncapped indexed ref" => ''false',line) + +write(*,'(a)') '// **************************************************************' +WRITE(*,'(A)') '// INDEXED VARIABLES' +write(*,'(a)') '// **************************************************************' + + call dcl_type(parser,'indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m=''1,_c:c=''0,_d:d=''1,_n:n}',line) + call dcl_type(parser,'indexed(t:int) is tuple(indexed_dim or int) except tuple(int)',line) + call dcl_uproc(parser,'PM__makeidxdim(x:null,y)=new indexed_dim {_n=y}',line) + call dcl_uproc(parser,'PM__makeidxdim(x:null)=new indexed_dim {_n=null}',line) + call dcl_uproc(parser,'PM__makeidxdim(x:range,y)=new indexed_dim {_c=x._lo,_n=y}',line) + call dcl_uproc(parser,'PM__makeidxdim(x:strided_range,y)=new indexed_dim {_c=x._lo,_m=x._st,_n=y}',line) + call dcl_uproc(parser,'PM__makeidxdim(x,y)=PM__makeidxdim(get_dim(x,y),y)',line) + call dcl_uproc(parser,'PM__makeidxdim(x:tuple)'//& + '=map($PM__makeidxdim,x,indices(x))',line) + call dcl_uproc(parser,'PM__makeidxdim(x:seq)=[PM__makeidxdim(x,''1)]',line) + + !!! Obsolete? + call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or indexed)='//& + 'new _indexed {_t=_tup(x),_r=null}',line) + call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or indexed,y)='//& + 'new _indexed {_t=_tup(x),_r=y}',line) + call dcl_uproc(parser,'PM__makeidx(x,y)=x :test "Malformed indexed expression" => ''false',line) + call dcl_uproc(parser,'PM__makeidx(x)=x :test "Malformed indexed expression" => ''false',line) + + call dcl_uproc(parser,'*%(x:indexed)=_dmap(x,here)',line) + call dcl_uproc(parser,'*%(x)=here check'//& + '"""*"" operator can only be applied to an ""indexed"" value"=>''false',line) + call dcl_uproc(parser,'*(x)=x check'//& + '"""*"" operator cannot be applied outside of a parallel context"=>''false',line) + + call dcl_uproc(parser,'+(x:indexed_dim,yy:any_int)='//& + 'new indexed_dim {_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'+(yy:any_int,x:indexed_dim)='//& + 'new indexed_dim {_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'-(x:indexed_dim,yy:any_int)='//& + 'new indexed_dim {_m=x._m,_c=x._c-y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'-(yy:any_int,x:indexed_dim)='//& + 'new indexed_dim {_m=-x._m,_c=-x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'*(x:indexed_dim,yy:any_int)='//& + 'new indexed_dim {_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'*(yy:any_int,x:indexed_dim)='//& + 'new indexed_dim {_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'/(x:indexed_dim,yy:any_int)='//& + 'new indexed_dim {_m=x._m,_c=x._c,_d=x._d*y,_n=x._n} where y=int(yy)',line) + call dcl_uproc(parser,'+(x:indexed_dim,y:indexed_dim)='//& + 'new indexed_dim {_m=x._m*y._d+y._m*x._d,_c=x._c*y._d+y._c*x._d,_d=x._d*y._d,_n=x._n}',line) + call dcl_uproc(parser,'-(x:indexed_dim,y:indexed_dim)='//& + 'new indexed_dim {_m=x._m*y._d-y._m*x._d,_c=x._c*y._d-y._c*x._d,_d=x._d*y._d,_n=x._n}',line) + + call dcl_uproc(parser,'string(x:indexed_dim)="($here."++x._n++"*"++x._m++"+"++x._c++")/"++x._d',line) + call dcl_uproc(parser,'string(x:indexed_dim(''1))="$here."++x._n++"*"++x._m++"+"++x._c',line) + call dcl_uproc(parser,'string(x:indexed_dim(''1,''1))="$here."++x._n++"+"++x._c',line) + call dcl_uproc(parser,'string(x:indexed_dim(''1,''1,''0))="$here."++x._n',line) + + call dcl_uproc(parser,'_correct(x:indexed,y:extent)=map($-,x,low(y))',line) + + call dcl_uproc(parser,'_dmap(x:any_int,n:int)=x',line) + call dcl_uproc(parser,'_dmap(x:any_int,n:grid_slice_dim)=single_point(x)',line) + call dcl_uproc(parser,'_dmap(x:any_int,n:tuple(int))=x',line) + call dcl_uproc(parser,'_dmap(x:any_int,n:tuple(grid_slice_dim))=single_point(x)',line) + call dcl_uproc(parser,'_dmap(x:indexed_dim,n:int)=(n*x._m+x._c)/x._d',line) + call dcl_uproc(parser,'_dmap(x:indexed_dim,n:tuple)=_dmap(x,get_dim(n,x._n))',line) + call dcl_uproc(parser,'_dmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi)'//& + 'where lo=_dmap(x,low(n)),hi=_dmap(x,high(n))',line) + call dcl_uproc(parser,'_dmap(x:indexed_dim(''1,''1),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st',line) + call dcl_uproc(parser,'_dmap(x:indexed_dim(''1,''1),n:block_seq)='//& + 'block_seq(n._lo+x._c,n._hi+x._c,n._st,n._b,n._align)',line) + call dcl_uproc(parser,'_dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)='//& + 'map_const($_dmap,x,n)',line) + call dcl_uproc(parser,'_dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)='//& + 's#map_const($_dmap,x,n)',line) + + call dcl_type(parser,'_round_up is unique',line) + call dcl_type(parser,'_round_down is unique',line) + call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:null)=null',line) + call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:int,r:_round_down)=(n*x._d-x._c)/x._m',line) + call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:int,r:_round_up)=(n*x._d+x._m-sign(1,x._m)-x._c)/x._m',line) + call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:tuple)=_dunmap(get_dim(n,x._n),x)',line) + call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:grid_slice_dim)='//& + 'min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up)',line) + call dcl_uproc(parser,& + '_dun(x:indexed_dim,m,n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m)))',line) + call dcl_uproc(parser,'_dun(x:int,m,n:extent)=n',line) + call dcl_uproc(parser,'_dunmap(x:indexed,m:grid_slice or tuple(int),n:extent)='//& + '_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n)',line) + call dcl_uproc(parser,'_dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)='//& + '_dun(x.1,m.1,n)',line) + +write(*,'(a)') '// Given tile and global region (which may be null) compute local region' + call dcl_uproc(parser,'_local_region(t,r:null)=t',line) + call dcl_uproc(parser,'_local_region(t,r)=intersect(t,r)',line) + + call dcl_uproc(parser,'_root_node(at:''true)=_root_node()',line) + call dcl_uproc(parser,'_root_node(at:''false)=_this_node()',line) + +write(*,'(a)') '// Resolve x[indexed]' + call dcl_uproc(parser,& + '_get_dindex(&a,x,shapex,local_tile,local_region,t:indexed,at) {'//& + 'tt=_correct(t,shapex._mshape);'//& + 'if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) {'//& + ' if at or a is <_comp^any> {'//& + ' _get_dindex_ss(&a,x,shapex,local_tile,local_region,tt,at);'//& + ' } else {'//& + ' _get_dindex_s(&a,x,shapex,local_tile,local_region,tt,at);'//& + ' }'//& + '} else {'//& + ' if at or a is <_comp^any> {'//& + ' _get_dindex_rs(&a,x,shapex,local_tile,local_region,tt,at);'//& + ' } else {'//& + ' _get_dindex_r(&a,x,shapex,local_tile,local_region,tt,at);'//& + ' }'//& + '}}',line) + +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])>=size(region)' +write(*,'(a)') '// -- in this case send one value for every point in current (sub)region' + call dcl_uproc(parser,& + '_get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& + 'PM__head_node{'//& + ' shapexx=#shapex._mshape;'//& + ' this_tile=shapex._tile;'//& + ' foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& + ' if contains(#(shapex.dist),p) {'//& + ' i=index(dims(shapex.dist),p);'//& + ' if i/=_this_node(){'//& + ' other_tile=element(shapex.dist,p);'//& + ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& + ' portion_to_recv=overlap(local_tile,dest_range2);'//& + ' if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv)'//& + ' }}};'//& + ' dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + ' foreach p in nodes_for_grid(local_region.dist,dest_range){'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(local_region.dist,p);'//& + ' portion_to_recv=intersect(other_tile,dest_range);'//& + ' if size(portion_to_recv)>0: '//& + ' _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile)'//& + ' }}};'//& + ' _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& + ' _sync_messages(a,x)}}',line) + +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])<=size(region)' +write(*,'(a)') '// -- in this case send those values in x which are needed to calculate x[indexed]' + call dcl_uproc(parser,& + '_get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& + 'shapexx=#shapex._mshape;'//& + 'src_range=_dmap(t,local_tile);var b=array(_arb(a),#src_range);'//& + 'foreach p in nodes_for_grid(shapex.dist,src_range) {'//& + ' if contains(#(shapex.dist),p) {'//& + ' i=index(dims(shapex.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(shapex.dist,p);'//& + ' portion_to_send=overlap(src_range,other_tile);'//& + ' if size(portion_to_send)>0:_recv_slice(i,&b,active_dims(src_range,portion_to_send));'//& + ' }}};'//& + ' dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + ' foreach p in nodes_for_grid(local_region.dist,dest_range){'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(local_region.dist,p);'//& + ' src_range2=_dmap(t,other_tile);'//& + ' portion_to_send=overlap(shapex._tile,src_range2);'//& + ' if size(portion_to_send)>0:_send_slice(i,x,portion_to_send);'//& + ' }}};'//& + ' u,v=overlap(src_range,shapex._tile);'//& + ' forall i in u,j in v{_set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>)};'//& + ' _sync_messages(x,b);'//& + '_copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t)}',line) + +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])>=size(region)' +write(*,'(a)') '// -- in this case send one value for every point in current (sub)region' +write(*,'(a)') '// -- Version for more complex types that need sync receive' + call dcl_uproc(parser,& + '_get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& + 'shapexx=#shapex._mshape;'//& + 'this_tile=shapex._tile;'//& + 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + 'foreach p in nodes_for_grid(local_region.dist,dest_range){'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(local_region.dist,p);'//& + ' portion_to_recv=intersect(other_tile,dest_range);'//& + ' if size(portion_to_recv)>0: '//& + ' _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile)'//& + '}}};'//& + '_copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& + 'foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& + ' if contains(#(shapex.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(shapex.dist,p);'//& + ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& + ' portion_to_recv=overlap(local_tile,dest_range2);'//& + ' if size(portion_to_recv)>0 { '//& + ' _recv_slice_sync(i,&a,portion_to_recv);'//& + '}}}};_sync_messages(a,x)}',line) + +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])<=size(region)' +write(*,'(a)') '// -- in this case send those values in x which are needed to calculate x[indexed]' +write(*,'(a)') '// -- Version for more complex types that need sync receive' + call dcl_uproc(parser,& + '_get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& + 'PM__head_node {'//& + 'shapexx=#shapex._mshape;'//& + 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + 'foreach p in nodes_for_grid(local_region.dist,dest_range){'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(local_region.dist,p);'//& + ' src_range=_dmap(t,other_tile);'//& + ' portion_to_send=overlap(shapex._tile,src_range);'//& + ' if size(portion_to_send)>0:_send_slice(i,x,portion_to_send);'//& + '}}}};'//& + 'src_range=_dmap(t,local_tile);var b=array(_arb(a),#src_range);'//& + 'if _head_node() or at { u,v=overlap(src_range,shapex._tile);'//& + ' forall i in u,j in v {_set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>)};'//& + ' foreach p in nodes_for_grid(shapex.dist,src_range) {'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(shapex.dist,p);'//& + ' portion_to_send=overlap(src_range,other_tile);'//& + ' if size(portion_to_send)>0{ PM__head_node{'//& + ' _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send))};'//& + ' if at:_bcast_slice_shared(&b,active_dims(src_range,portion_to_send))}'//& + ' }}}};'//& + ' _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t);'//& + ' _sync_messages(x,b)}',line) + + call dcl_uproc(parser,'_copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) {'//& + 'u=overlap(a_tile,_dunmap(t,b_tile,a_extent));'//& + 'forall i in u {'//& + ' j=b_tile#_dmap(t,a_tile[i]);if j in #b_tile:_set_elem(&a,PM__getelem(b,j),i <>) '//& + '}}',line) + + call dcl_uproc(parser,'_copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) {'//& + 'u=intersect(a_tile,_dunmap(t,b_tile,a_extent));'//& + 'forall i in u { bb=_import_dref%(b);_set_elem(&a,_getref(bb,i),a_tile#i <>);'//& + '}}',line) + +write(*,'(a)') '// Resolve x[ indexed ][ indexed or shared ] ... ' + call dcl_uproc(parser,& + '_get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) {'//& + 't=_correct(tt,shapex._mshape);shapexx=#shapex._mshape;'//& + 'this_tile=shapex._tile;'//& + 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + 'foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& + ' if contains(#(shapex.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node(){'//& + ' other_tile=element(shapex.dist,p);'//& + ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& + ' portion_to_recv=overlap(local_tile,dest_range2);'//& + ' if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv);'//& + '}}};'//& + 'nodes=nodes_for_grid(local_region.dist,dest_range);'//& + 'var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes);'//& + 'foreach pp in #nodes {'//& + ' p=nodes[pp];'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(local_region.dist,p);'//& + ' portion_to_recv=intersect(other_tile,dest_range);'//& + ' if size(portion_to_recv)>0 {'//& + ' b[pp]={_getref(_import_dref%(x),h):h in portion_to_recv};'//& + ' _isend(i,b[pp]) }'//& + '}}};'//& + '_copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& + '_sync_messages(a,x)'//& + '}',line) + + +write(*,'(a)') '// Resolve x[ indexed ][ indexed or shared ] ... ' + call dcl_uproc(parser,& + '_get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) {'//& + 't=_correct(tt,shapex._mshape);shapexx=#shapex._mshape;'//& + 'this_tile=shapex._tile;'//& + 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + 'nodes=nodes_for_grid(local_region.dist,dest_range);'//& + 'var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes);'//& + ' foreach pp in #nodes {'//& + ' p=nodes[pp];'//& + ' if contains(#(local_region.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node() {'//& + ' other_tile=element(local_region.dist,p);'//& + ' portion_to_recv=intersect(other_tile,dest_range);'//& + ' if size(portion_to_recv)>0 {'//& + ' b[pp]={_getref(_import_dref%(x),h):h in portion_to_recv};'//& + ' _isend(i,b[pp]) }'//& + '}}};'//& + '_copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& + 'foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& + ' if contains(#(shapex.dist),p) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if i/=_this_node(){'//& + ' other_tile=element(shapex.dist,p);'//& + ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& + ' portion_to_recv=overlap(local_tile,dest_range2);'//& + ' if size(portion_to_recv)>0{ PM__head_node{ _recv_slice_sync(i,&a,portion_to_recv)};'//& + ' if at:_bcast_slice_shared(&a,portion_to_recv);}'//& + ' }};'//& + '};_sync_messages(a,x)}',line) + +write(*,'(a)') '// Resolve x[ indexed ][ priv ]' + call dcl_uproc(parser,& + '_get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:indexed,complt,at) {'//& + 'dest_range=_dmap(t,this_tile,#shapex._mshape);'//& + ' foreach p in nodes_for_grid(shapex.dist,dest_range){'//& + ' i=index(dims(local_region.dist),p);'//& + ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& + ' other_tile=element(shapex.dist,p);'//& + ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& + ' _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt)'//& + '}};'//& + 'src_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + 'forall j in overlap(this_tile,src_range) {'//& + ' jj=index(#this_tile,j);PM__do_at size(this_tile),jj,aa,a,xx,x { '//& + ' PM__assign(&aa,_getref(xx,null))}}; '//& + 'foreach p in nodes_for_grid(local_region.dist,src_range) {'//& + ' if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() {'//& + ' PM__recv_req pp,xx,x,_getref(xx,null)'//& + ' }};'//& + 'if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){'//& + ' i=index(dims(local_region.dist),p);'//& + ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& + ' other_tile=element(shapex.dist,p);'//& + ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& + ' _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt)'//& + '}};'//& + ' _sync_messages(a,x)'//& + '}',line) + +write(*,'(a)') '// Resolve x[ indexed ][ whatever ] = priv' + call dcl_uproc(parser,& + '_set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed,'//& + ' pr:invar proc,complt:invar,at:invar) PM__node <>:'//& + '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at)',line) + call dcl_uproc(parser,& + '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed,'//& + ' pr:proc,complt,at) {'//& + 't=_correct(tt,shapex._mshape);dest_range=_dmap(t,this_tile,#shapex._mshape);'//& + 'PM__head_node{foreach p in nodes_for_grid(shapex.dist,dest_range){'//& + ' i=index(dims(shapex.dist),p);'//& + ' if contains(#(shapex.dist),p) and i/=_this_node() {'//& + ' other_tile=element(shapex.dist,p);'//& + ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& + ' _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt)'//& + '}}};'//& + 'src_range=_dunmap(t,shapex._tile,local_region._mshape);'//& + 'for j in overlap(this_tile,src_range) {'//& + ' jj=index(#this_tile,j);PM__do_at size(this_tile),jj,yy,y,xx,x { '//& + ' PM__assign(&^(_getlhs(xx,null)),yy,pr)}}; '//& + 'foreach p in nodes_for_grid(local_region.dist,src_range) {'//& + ' i=index(dims(local_region.dist),p);'//& + ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& + 'PM__recv_assn pp,xx,yy,x,y,at{PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}'//& + '}};'//& + '_sync_messages(x,y)}',line) + +write(*,'(a)') '// **************************************************************' +write(*,'(a)') '// Envelope and stencil definitions' +write(*,'(a)') '// **************************************************************' + + call dcl_type(parser,'envelope is rec{cross:extent or null,corner:extent or null,envelope:extent}',line) + call dcl_uproc(parser,'ortho(x:extent)=new envelope {cross=x,corner=spread(0..0,x),envelope=x}',line) + call dcl_uproc(parser,'ortho(x:extent,y:extent)='//& + 'new envelope {cross=if(x inc y=>x,y),corner=y,envelope=envelope(x,y)}',line) + call dcl_uproc(parser,'envelope(x:envelope)=x.envelope',line) + call dcl_uproc(parser,'envelope(x:extent)=x',line) + call dcl_uproc(parser,'envelope(x:any_int,y:any_int)='//& + 'min(xx,yy)..max(xx,yy) where xx=int(x),yy=int(y)',line) + call dcl_uproc(parser,'envelope(x:any_int,y:seq(any_int))=envelope(x..x,y)',line) + call dcl_uproc(parser,'envelope(x:seq(any_int),y:any_int)=envelope(x,y..y)',line) + call dcl_uproc(parser,'envelope(x:seq(any_int),y:seq(any_int))='//& + 'if(size(x)>0=>if(size(y)>0=>min(lx,ly)..max(hx,hy),lx..hx),if(size(y)>0=>0..0,ly..hy)) '//& + 'where lx=min(llx,hhx),ly=min(lly,hhy),hx=max(llx,hhx),hy=max(lly,hhy)'//& + 'where llx=int(low(x)),lly=int(low(y)),hhx=int(high(x)),hhy=int(high(y))',line) + call dcl_uproc(parser,'envelope(x:tuple,y:tuple)=map($envelope,x,y)',line) + call dcl_uproc(parser,'envelope(x:null,y:extent)=y',line) + call dcl_uproc(parser,'envelope(x:extent,y:null)=x',line) + call dcl_uproc(parser,'envelope(x:extent or null,y:envelope)=envelope(x,y.envelope)',line) + call dcl_uproc(parser,'envelope(x:envelope,y:extent or null)=envelope(x.envelope,y)',line) + call dcl_uproc(parser,'envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope)',line) + call dcl_uproc(parser,'string(x:envelope)=string(x.cross++" ortho "++x.corner)',line) + +write(*,'(a)') '// **************************************************************' +write(*,'(a)') '// Support for nhd statement' +write(*,'(a)') '// **************************************************************' + + call dcl_type(parser,'_nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits}',line) + call dcl_type(parser,'nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here}',line) + call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,bound:invar) shared <>='//& + 'new _nhd {_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),'//& + '_limits=_expand_limits(region._extent,envelope(x),bound)} '//& + 'where t=_get_halo(region,region._tile,envelope(x))',line) + call dcl_uproc(parser,'PM__nhd%(x,bound:invar)='//& + '^(new _nhd {_nbhd=n,_tile=t,_tilesz=#t,_interior=t,'//& + '_limits=region._extent},shared) '//& + 'where t=region._tile where n=xx '//& + 'where xx=spread(0..0,here){_check_nhd%(x)}',line) + call dcl_uproc(parser,'_check_nhd%(n:invar envelope or extent) {}',line) + call dcl_uproc(parser,'_check_nhd%(n:extent):test "Neighbourhood must be invar"=>''false',line) + call dcl_uproc(parser,'_check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>''false',line) + + call dcl_uproc(parser,'PM__check_bounds%(b:invar boundary){_check_ranks(extent(region),b)}',line) + call dcl_uproc(parser,'PM__check_bounds%(b:boundary):test "Bounds must be ""invar"""=>''false',line) + call dcl_uproc(parser,'PM__check_bounds%(b):test "Bounds must have a boundary type"=>''false',line) + call dcl_uproc(parser,'_check_ranks(n:tuple,b:tuple):'//& + 'test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b))',line) + call dcl_uproc(parser,'_check_ranks(n:envelope,b:tuple):'//& + 'test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n.cross),rank(b))',line) + call dcl_uproc(parser,'_check_ranks(n,b:tuple):'//& + 'test "Rank of boundary does not match that of neighbourhood"=>same_type(''1,rank(b))',line) + call dcl_uproc(parser,'_check_ranks(n,b){}',line) + + call dcl_type(parser,'boundary is boundary_dim,tuple(boundary_dim)',line) + call dcl_type(parser,'boundary_dim is CYCLE,EXCLUDED,range(int),null',line) + call dcl_type(parser,'CYCLE is unique',line) + call dcl_type(parser,'EXCLUDED is unique',line) + + call dcl_uproc(parser,'_expand_limits(t:range(int),n:range(int),b:boundary_dim)=t',line) + call dcl_uproc(parser,'_expand_limits(t:range(int),n:range(int),b:CYCLE)=_exterior(t,n)',line) + call dcl_uproc(parser,'_expand_limits(t:tuple,n:tuple,b:boundary_dim)=map($_expand_limits,t,n,spread(b,n))',line) + call dcl_uproc(parser,'_expand_limits(t:tuple,n:tuple,b:tuple(boundary_dim))='//& + 'map($_expand_limits,t,n,b)',line) + + call dcl_uproc(parser,'PM__set_nhd%(&n,x:complete){'//& + 'n._array[n._nbhd._interior[n._index]]=x}',line) + call dcl_uproc(parser,'PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]=x'//& + ' check "Expression in ""nhd"" must be ""complete"""=>''false',line) + + call dcl_uproc(parser,'PM__nhd_join(x)=x._array',line) + call dcl_uproc(parser,'PM__nhd_join(x,y)=new _join{head=x,tail=y._array}',line) + call dcl_uproc(parser,'PM__nhd_var%(x,n:_nhd,i,h)<>='//& + 'new nbhd{_array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h}',line) + call dcl_uproc(parser,'PM__nhd_active(region,nbhd,bound:null)=region._extent',line) + call dcl_uproc(parser,& + 'PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound)',line) + call dcl_uproc(parser,'PM__nhd_active(region,nbhd,bound){'//& + 'r=PM__nhd_active(region,nbhd,spread(bound,region._extent));return r}',line) + call dcl_uproc(parser,'_nhd_active(r,n,b:CYCLE or null)=r',line) + call dcl_uproc(parser,'_nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b))',line) + call dcl_uproc(parser,'_nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n)',line) + + call dcl_uproc(parser,'_make_nhd%(x:invar,d:invar) shared <>{var v=array(x,d);return v}',line) + + call dcl_uproc(parser,'PM__set_edge%(&x,y,z){}',line) + + call dcl_uproc(parser,'PM__subref(x:nbhd,t:subs)=_nhd_sub(x,t)',line) + call dcl_uproc(parser,'PM__subref(x:nbhd,t:null)=_nhd_sub(x,t)',line) + + call dcl_uproc(parser,'_nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))='//& + 'PM__subref(x._array,tt+x._nbhd._interior[x._index]) {'//& + 'tt=_tup(t);'//& + 'test "Subscript"++tt++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),'//& + '"At "++x._here++" nhd "++tt++" goes outside of boundary "++limits=>'//& + 'contains(limits,dtt) where limits=x._nbhd._limits '//& + ' where dtt=tt+x._here}',line) + call dcl_uproc(parser,'_nhd_sub(x:nbhd,t)=_arb(x._array)'//& + 'check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>''false',line) + + call dcl_uproc(parser,'PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>''false',line) + + call dcl_uproc(parser,'envelope(x:_nhd)=envelope(x._nbhd)',line) + call dcl_uproc(parser,'envelope(x,y:_nhd)=envelope(x,y._nbhd)',line) + call dcl_uproc(parser,'envelope(x:_nhd,y:_nhd)=envelope(x._nbhd,y._nbhd)',line) + + call dcl_type(parser,'_join is struct^{head,tail}',line) + + call dcl_uproc(parser,'PM__blocking%(x:null){}',line) + call dcl_uproc(parser,'PM__blocking%(x):'//& + 'test "Block expression must be tuple of integers"=>''false',line) + call dcl_uproc(parser,'PM__blocking%(x:tuple(any_int)){'//& + 'test "Rank of ""block="" does not match region"=>same_type(rank(x),rank(region));'//& + 'test "Block sizes must be positive"=>map_reduce($_positive,$and,x)}',line) + call dcl_uproc(parser,'_positive(x)=x>0',line) + + call dcl_uproc(parser,& + 'PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { '//& + ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& + ' pp=index2point(_this_node(),dims(region.dist));'//& + ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' tile_x=_get_halo(region._mshape,region._tile,'//& + ' _foot(i-pp,nbhd._nbhd));'//& + ' ov=this_tile_x#intersect(tile_x,other_tile);if size(ov)>0 {'//& + ' _recv_slice(p,&a,ov)'//& + ' }}'//& + ' };'//& + ' foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd));'//& + ' ov=overlap(this_tile_x,intersect(this_tile,other_tile_x));if size(ov)>0 {'//& + ' _send_slice(p,a,ov)'//& + ' }} '//& + ' };'//& + '_apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''false)'//& + '}}',line) + + call dcl_uproc(parser,& + 'PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& + ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& + ' pp=index2point(_this_node(),dims(region.dist));'//& + ' foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd));'//& + ' ov=overlap(this_tile_x,intersect(this_tile,other_tile_x));if size(ov)>0 {'//& + ' _send_slice(p,a,ov);'//& + ' }} '//& + ' };'//& + '_apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''false)'//& + '}}',line) + + call dcl_uproc(parser,'inside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo..lo-y,hi-y..hi))'//& + ' where lo=low(x),hi=high(x)',line) + call dcl_uproc(parser,'inside_edge(x:extent,y:tuple(int))=map($inside_edge,x,y)',line) + call dcl_uproc(parser,'outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y))'//& + ' where lo=low(x),hi=high(x)',line) + call dcl_uproc(parser,'outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y)',line) + + + call dcl_uproc(parser,'_foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner)',line) + call dcl_uproc(parser,'_foot(d,n:extent)=n',line) + + call dcl_uproc(parser,'PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& + 'PM__head_node{_apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''true)}}',line) + + call dcl_uproc(parser,& + 'PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& + ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& + ' pp=index2point(_this_node(),dims(region.dist));'//& + ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' tile_x=_get_halo(region._mshape,region._tile,'//& + ' _foot(i-pp,nbhd._nbhd));'//& + ' ov=this_tile_x#intersect(tile_x,other_tile);if size(ov)>0 {'//& + ' _recv_slice_sync(p,&a,ov);'//& + ' }}'//& + ' };'//& + '_apply_boundaries(&a,region,envelope(nbhd._nbhd),region._tile,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''true)'//& + '}}',line) + + call dcl_uproc(parser,& + 'PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& + 'if shrd_nnode()>1 {'//& + ' foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 {'//& + ' chunk=chunk(region,envelope(nbhd._nbhd),i,b);'//& + ' _bcast_slice_shared(&a,chunk)'//& + '}}}',line) + + call dcl_uproc(parser,'_rev(a:tuple)=map($_rev,a)',line) + call dcl_uproc(parser,'_rev(a:range)=-high(a)..-low(a)',line) + + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index,recv) { '//& + '_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,get_dim(bound,index),index,recv);'//& + '_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index-''1,recv)}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index:''0,recv)'//& + ' {}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index,recv) {}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:CYCLE,index,recv) { '//& + 'ex=get_dim(extent,index);ev=get_dim(envelope,index);'//& + 'lo=low(ex);hi=high(ex);up=max(high(ev),0);down=min(low(ev),0);'//& + 'upper_outside=replace(extent,index,hi+1..hi+up);'//& + 'upper_inside=replace(extent,index,hi+down+1..hi);'//& + 'lower_outside=replace(extent,index,lo+down..lo-1);'//& + 'lower_inside=replace(extent,index,lo..lo+up-1);'//& + '_copy_bounds(&a,d,n,this_tile_x,upper_outside,lower_inside,recv);'//& + '_copy_bounds(&a,d,n,this_tile_x,lower_outside,upper_inside,recv)}',line) + + call dcl_uproc(parser,'_copy_bounds(&a,d,n,this_tile_x,to,from,recv:''false) {'//& + 'oldpart,oldtile=overlap(from,d._tile);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'foreach pp in nodes_for_grid(d.dist,element(from,newpart)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(to,overlap(from,element(d.dist,p)));'//& + ' ov=overlap(this_tile_x,tile);'//& + ' if size(ov)>0{_recv_slice(p,&a,ov)}}'//& + '};'//& + 'foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n)));'//& + ' ov=this_tile_x#intersect(d._tile,tile);'//& + ' if size(ov)>0{_send_slice(p,a,ov)}}'//& + '}}',line) + + call dcl_uproc(parser,'_copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:''false) {'//& + 'oldpart,oldtile=overlap(from,d._tile);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n)));'//& + ' ov=this_tile_x#intersect(d._tile,tile);'//& + ' if size(ov)>0{_send_slice(p,a,ov)}}'//& + '}}',line) + + call dcl_uproc(parser,'_copy_bounds(&a,d,n,this_tile_x,to,from,recv:''true) {'//& + 'oldpart,oldtile=overlap(from,this_tile_x);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'o,oo=overlap(newpart,oldpart);'//& + '_set_slice(&a,element(newtile,o),a,element(oldtile,oo))}',line) + + call dcl_uproc(parser,'_copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:''true) {'//& + 'oldpart,oldtile=overlap(from,this_tile_x);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'o,oo=overlap(newpart,oldpart);'//& + '_set_slice(&a,element(newtile,o),a,'//& + ' element(oldtile,oo));'//& + 'foreach pp in nodes_for_grid(d.dist,element(from,newpart)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(to,overlap(from,element(d.dist,p)));'//& + ' _recv_slice(p,&a,overlap(this_tile_x,tile))}'//& + '}}',line) + + call dcl_uproc(parser,'_send_slice(p,a:_join,o) {_send_slice(p,a.head,o);_send_slice(p,a.tail,o)}',line) + call dcl_uproc(parser,'_recv_slice(p,&a:_join,o) {_recv_slice(p,&a.head,o);_recv_slice(p,&a.tail,o)}',line) + call dcl_uproc(parser,'_recv_slice_sync(p,&a:_join,o)'//& + '{_recv_slice_sync(p,&a.head,o);_recv_slice_sync(p,&a.tail,o)}',line) + call dcl_uproc(parser,'_bcast_slice_shared(&a:_join,o)'//& + ' {_bcast_slice_shared(&a.head,o);_bcast_slice_shared(&a.tail,o)}',line) + call dcl_uproc(parser,'_sync_messages(x:_join):_sync_messages(x.head,x.tail)',line) + + call dcl_uproc(parser,'_not_zero(x)=if(x/=0=>1,0)',line) + call dcl_uproc(parser,'_crss(x)=1==map_reduce($_not_zero,$+,x)',line) + + +write(*,'(a)') '// Add (anti) halo around tile' +write(*,'(a)') '// Args: mshape / tile / displacement' +write(*,'(a)') '// (mshape not used at the moment - there to cope with other topologies)' +write(*,'(a)') '// Result: expanded tile' + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:range(int),i:any_int)='//& + 'low(t)+ii..high(t)+ii where ii=int(i)',line) + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:strided_range(int),i:any_int)='//& + ' low(t)+ii..high(t)+ii by step(t) where ii=int(i)',line) + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:block_seq,i:any_int){'//& + 'return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i)}',line) + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:map_seq,i:any_int) {'//& + 'var a=array(0,size(t));for j in a,k in t.array:j=k+i;return new map_seq {array=a}}',line) + + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:range(int),i:range(any_int))='//& + 'low(t)+int(low(i))..high(t)+int(high(i))',line) + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:strided_range(int),i:range(any_int)){'//& + 'var step=step(t);var width=size(i);'//& + 'if width>step {step=1;width=1};'//& + 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0)}',line) + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:block_seq,i:range(any_int)){'//& + 'var step=step(t);var width=size(i)+width(t)-1;'//& + 'if width>step {step=1;width=1}'//& + 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0)}',line) + call dcl_uproc(parser,& + '_get_halo(d:range(int),t:map_seq,i:range(any_int)) {'//& + 'var a=array(0,[0..size(t)*size(i)-1]);var m=0;'//& + '_expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i));'//& + 'return _redim(a,shape(m))}',line) + call dcl_uproc(parser,& + '_get_halo(d:extent,j:grid,i:tuple(any_int or range(any_int)))='//& + ' map($_get_halo,d,j,i)',line) + call dcl_uproc(parser,& + '_get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))='//& + '_get_halo(d.1,t.1,i)',line) + call dcl_uproc(parser,'_get_halo(d,t,i:null)=t',line) + + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:range(int),i:any_int)='//& + 'low(t)-ii..high(t)-ii where ii=int(i)',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:strided_range(int),i:any_int)='//& + ' low(t)-ii..high(t)-ii by step(t) where ii=int(i)',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:block_seq,i:any_int){'//& + 'return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i)}',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:map_seq,i:any_int) {'//& + 'var a=array(0,size(t));for j in a,k in t.array:j=k-i;return new map_seq {array=a}}',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:range(int),i:range(any_int))='//& + 'low(t)-int(high(i))..high(t)-int(low(i))',line) + + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){'//& + 'var step=step(t);var width=size(i);'//& + 'if width>step {step=1;width=1}'//& + 'return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width)}',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){'//& + 'var step=step(t);var width=size(i)+width(t)-1;'//& + 'if width>step {step=1;width=1}'//& + 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width)}',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) {'//& + 'var a=array(0,[0..size(t)*size(i)-1]);var m=0;'//& + '_expand_aseq(&m,t.array,size(t.array),&a,-high(i),-low(i));'//& + 'return _redim(a,shape(m))}',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:extent,j:grid,'//& + ' i:tuple(any_int or range(any_int)))='//& + ' map($_get_anti_halo,d,j,i)',line) + call dcl_uproc(parser,& + '_get_anti_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))='//& + '_get_anti_halo(d.1,t.1,i)',line) + call dcl_uproc(parser,'_get_anti_halo(d,t,i:null)=t',line) + + call dcl_uproc(parser,'_interior(t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n))',line) + call dcl_uproc(parser,'_interior(t:strided_range,n:range)=1..0 by 1',line) + call dcl_uproc(parser,'_interior(tt:block_seq,n:range)='//& + 'block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)'//& + 'where t=middle_blocks(tt)',line) + + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:''true)='//& + 'low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1)',line) + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:''false)='//& + 'low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t)',line) + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:_down)='//& + 'low(t)+w..low(t)+w+w-1 where w=max(0,-low(n))',line) + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:_up)='//& + 'high(t)-w-w+1..high(t)-w where w=max(0,high(n))',line) + call dcl_uproc(parser,'_get_chunk(tt:block_seq,n:range,l:''true)='//& + 'if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t))'//& + ' where t=middle_blocks(tt)',line) + call dcl_uproc(parser,'_get_chunk(tt:block_seq,n:range,l:''false)='//& + 'if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t))'//& + ' where t=middle_blocks(tt)',line) + call dcl_uproc(parser,'_get_chunk(t:grid_dim,n:range,l:_left or _right)=empty(t)',line) + call dcl_uproc(parser,'_get_chunk(t:block_seq,n:range,l:_left)='//& + 'block_seq(low(b),high(b),1,1,0) where b=first_block(t)',line) + call dcl_uproc(parser,'_get_chunk(t:block_seq,n:range,l:_right)='//& + 'block_seq(low(b),high(b),1,1,0) where b=last_block(t)',line) + + call dcl_uproc(parser,'_chunk(t,n,r,e,l)='//& + 'if(r>e=>_interior(t,n),rt,_get_chunk(t,n,l))',line) + + call dcl_uproc(parser,'_get_chunk(t:tuple1d,n,e,l)=[_chunk(t.1,n.1,1,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple2d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple3d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple4d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple5d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple6d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),'//& + '_chunk(t.6,n.6,6,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple7d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),'//& + '_chunk(t.6,n.6,6,e,l),_chunk(t.7,n.7,7,e,l)]',line) + + call dcl_uproc(parser,'chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1',line) + call dcl_uproc(parser,'chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1',line) + call dcl_uproc(parser,'chunks(t:grid,n:extent)=2',line) + + call dcl_uproc(parser,'_cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n',line) + + call dcl_uproc(parser,'chunk(t:tuple(range(any_int)),n:extent,i:int) {'//& + ' _cr(i,rank(t)*2);var r=n;'//& + ' if i==0: r=map($_interior,t,n) elseif i&1==0: r=_get_chunk(t,n,(i+1)/2,''true) '//& + ' else: r=_get_chunk(t,n,(i+1)/2,''false);return r}',line) + + call dcl_type(parser,'_left is unique',line) + call dcl_type(parser,'_right is unique',line) + call dcl_type(parser,'_up is unique',line) + call dcl_type(parser,'_down is unique',line) + + call dcl_uproc(parser,'chunk(t:tuple(range(any_int) or block_seq),n:extent,i:int) {'//& + '_cr(i,rank(t)*4);var r=t;if i==0:r=map($_interior,t,n) else: switch (i-1)&3 {'//& + 'case 0:r=_get_chunk(t,n,(i+3)/4,''true);'//& + 'case 1:r=_get_chunk(t,n,(i+3)/4,''false);'//& + 'case 2:r=_get_chunk(t,n,(i+3)/4,_left);'//& + 'default:r=_get_chunk(t,n,(i+3)/4,_right);'//& + '};return r}',line) + call dcl_uproc(parser,'chunk(t:grid,n:extent,i:int) {'//& + '_cr(i,1);var r=#t;if i==0:r=empty(#t);return r}',line) + + call dcl_uproc(parser,'chunk(t:grid,n:extent,i:int,b:null)='//& + 'chunk(t,n,i)',line) + call dcl_uproc(parser,'chunk(t:grid,n:extent,i:int,b:extent)='//& + 'intersect(chunk(t,n,i),b)',line) + + call dcl_uproc(parser,'inside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)='//& + '_get_chunk(t,n,i,low)',line) + call dcl_uproc(parser,'outside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)='//& + '_get_chunk(map($_exterior,t,n),n,i,low)',line) + call dcl_uproc(parser,'outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:''true)='//& + '_get_chunk(map($_exterior,t,n),n,i,_up)',line) + call dcl_uproc(parser,'outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:''false)='//& + '_get_chunk(map($_exterior,t,n),n,i,_down)',line) + + call dcl_uproc(parser,'_exterior(t:range(int),n:range(int))=low(t)+min(low(n),0)..high(t)+max(high(n),0)',line) + call dcl_uproc(parser,'_get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) {'//& + ' var r=t;tt=map($_exterior,t,n);'//& + ' if i==0: r=#tt elseif i&1==0: r=_get_chunk(tt,n,(i+1)/2,_up)'//& + ' else: r=_get_chunk(tt,n,(i+1)/2,_down);return r}',line) + + +write(*,'(a)') '// *************************************************************' +write(*,'(a)') '// nbr% and nbhd% intrinsics' +write(*,'(a)') '// *************************************************************' + + call dcl_type(parser,'disp_index is any_int,tuple(any_int)',line) + call dcl_type(parser,& + 'disp_sub is disp_index,tuple(any_int or range(any_int))',line) + +write(*,'(a)') '// *** Default ***' + call dcl_uproc(parser,'nbr%(x:chan,t:shared disp_index,v:shared){'//& + ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& + ' j=displace(region._mshape,here,t);'//& + ' var y=v;if contains(region._mshape,j) {y=x![j]};'//& + ' return y} ',line) + call dcl_uproc(parser,& + 'nbhd%(x:chan,t:shared disp_sub,v:shared) { '//& + ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& + ' var a=array(v,#t);'//& + ' foreach invar i in t {'//& + ' j=displace(region._mshape,here,i);'//& + ' if j in region._mshape {a[here]=x![j]}'//& + ' };return a}',line) + +write(*,'(a)') '// *** Blocked distributions ***' + call dcl_uproc(parser,& + 'nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) {'//& + ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& + ' var j=displace(region._mshape,here,t);'//& + ' a,ad=tile_with_halo%(x,t,v);'//& + ' return a[ad#j]}',& + line) + call dcl_uproc(parser,& + 'nbhd%(region:dshape(,blocked_distr),x:chan,t:shared disp_sub,v:shared){ '//& + ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& + ' a=displace(region._mshape,here,t);'//& + ' y,yd=tile_with_halo%(x,t,v);'//& + ' return y[yd#a]'//& + '} ',& + line) + + call dcl_uproc(parser,'tile_with_halo%(x,t,v) {return a,d '//& + 'where a,d=_local_tile_with_halo(region,PM__local(x),t,v)}',line) + +write(*,'(a)') '// Return local tile with halo cells ' + call dcl_uproc(parser,& + '_local_tile_with_halo(region,x,t,v) { '//& + ' this_tile_x=_get_halo(region._mshape,region._tile,t);'//& + ' var a=array(v,#this_tile_x);'//& + ' foreach i in nodes_for_grid(region.dist,this_tile_x) {'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& + ' var p=index(dims(region.dist),i);'//& + ' if contains(#region.dist,i) and p/=_this_node() {'//& + ' _recv_slice(p,&a,overlap(this_tile_x,other_tile));'//& + ' } '//& + ' };'//& + ' foreach i in '//& + ' nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) {'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& + ' p=index(dims(region.dist),i);'//& + ' if contains(#region.dist,i) and p/=_this_node() {'//& + ' _send_slice(p,x,overlap(region._tile,other_tile_x));'//& + ' } '//& + ' };'//& + ' o,oo=overlap(this_tile_x,region._tile);a[o]=x[oo];'//& + ' _sync_messages(a,x);return a,this_tile_x }',line) + + call dcl_uproc(parser,& + '_local_tile_with_halo(region,x:_comp,t,v) { '//& + ' this_tile_x=_get_halo(region._mshape,region._tile,t);'//& + ' var a=array(v,#this_tile_x);'//& + ' foreach i in '//& + ' nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) {'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& + ' p=index(dims(region.dist),i);'//& + ' if contains(#region.dist,i) and p/=_this_node() {'//& + ' _send_slice(p,x,overlap(region._tile,other_tile_x));'//& + ' } '//& + ' };'//& + ' o,oo=overlap(this_tile_x,region._tile);a[o]=x[oo];'//& + ' foreach i in nodes_for_grid(region.dist,this_tile_x) {'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& + ' p=index(dims(region.dist),i);'//& + ' if contains(dims(region.dist),i) and p/=_this_node() {'//& + ' _recv_slice_sync(p,&a,overlap(this_tile_x,other_tile));'//& + ' } '//& + ' };'//& + ' _sync_messages(a,x);return a,this_tile_x }',line) + +write(*,'(a)') '// Displace x by y within mshape d' + call dcl_uproc(parser,'displace(d:range(int),x:int,y:any_int)='//& + 'x+int(y)',line) + call dcl_uproc(parser,'displace(d:range(int),x:int,y:range(any_int))='//& + 'x+int(y._lo)..x+int(y._hi)',line) + call dcl_uproc(parser,'displace(d:extent1d,x:tuple1d(int),y:range(any_int) or any_int)='//& + 'displace(d.1,x.1,y)',line) + call dcl_uproc(parser,'displace(d:extent,'//& + 'x:tuple(int),y:tuple(range(any_int) or any_int))='//& + 'map($displace,d,x,y)',line) + + +write(*,'(a)') '// ************************************************' +WRITE(*,'(A)') '// TOPOLOGIES' +write(*,'(a)') '// ************************************************' + + call dcl_uproc(parser,& + 'topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l)',line) + call dcl_uproc(parser,& + 'topology(tp,dis,d,l:int)=tp',line) + + call dcl_proc(parser,'_get_dims(int,int)->int',"get_dims",0,& + line,proc_is_impure) + call dcl_proc(parser,'_get_dims(int,int,int)->int,int',& + "get_dims",0,& + line,proc_is_impure) + call dcl_proc(parser,'_get_dims(int,int,int,int)->int,int,int',& + "get_dims",0,& + line,proc_is_impure) + call dcl_proc(parser,& + '_get_dims(int,int,int,int,int)->int,int,int,int',& + "get_dims",0,& + line,proc_is_impure) + call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->'//& + 'int,int,int,int,int',& + "get_dims",0,& + line,proc_is_impure) + call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->'//& + 'int,int,int,int,int,int',& + "get_dims",0,& + line,proc_is_impure) + call dcl_proc(parser,& + '_get_dims(int,int,int,int,int,int,int,int)->'//& + 'int,int,int,int,int,int,int',& + "get_dims",0,& + line,proc_is_impure) + + call dcl_uproc(parser,'_zd(x,y)=if(x==1=>1,nodes_needed(y,x))',line) +!!$ call dcl_uproc(parser,& +!!$ 'cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,dd,n)',line) + call dcl_uproc(parser,& + 'cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,spread(VBLOCK,dd),n)',line) + call dcl_uproc(parser,& + 'cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n)',line) + call dcl_uproc(parser,& + 'cart_topo(d:tuple1d,t:tuple1d,n:int)='//& + 'tuple(_get_dims(n,_zd(d.1,t.1)))',line) + call dcl_uproc(parser,'cart_topo(d:tuple2d,t:tuple2d,n:int)=tuple(b,a) '//& + 'where a,b=_get_dims(n,_zd(d.2,t.2),_zd(d.1,t.1))',line) + call dcl_uproc(parser,'cart_topo(d:tuple3d,t:tuple3d,n:int)=tuple(c,b,a) '//& + 'where a,b,c=_get_dims(n,_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) + call dcl_uproc(parser,'cart_topo(d:tuple4d,t:tuple4d,n:int)=tuple(dd,c,b,a) '//& + 'where a,b,c,dd=_get_dims(n,_zd(d.4,t.4),_zd(d.3,t.3),'//& + '_zd(d.2,t.2),_zd(d.1,t.1))',line) + call dcl_uproc(parser,'cart_topo(d:tuple5d,t:tuple5d,n:int)=tuple(e,dd,c,b,a) '//& + 'where a,b,c,dd,e=_get_dims(n,_zd(d.5,t.5),_zd(d.4,t.4),'//& + '_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) + call dcl_uproc(parser,'cart_topo(d:tuple6d,t:tuple6d,n:int)=tuple(f,e,dd,c,b,a) '//& + 'where a,b,c,dd,e,f=_get_dims(n,_zd(d.6,t.6),_zd(d.5,t.5),'//& + '_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) + call dcl_uproc(parser,'cart_topo(d:tuple7d,t:tuple7d,n:int)=tuple(g,f,e,dd,c,b,a) '//& + 'where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),'//& + '_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) + +write(*,'(a)') '// ************************************************' +WRITE(*,'(A)') '// DISTRIBUTIONS' +write(*,'(a)') '// ************************************************' + call dcl_type(parser,& + 'distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr',line) + call dcl_type(parser,'distr:iterable is null,blocked_distr,distr_dim,tuple(distr_dim),sliced_distr',line) + call dcl_type(parser,'blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr)',line) + + call dcl_type(parser,& + 'distr_template is null,distr_template_dim,tuple(distr_template_dim),...',line) + call dcl_type(parser,& + 'distr_template_dim is null,vblock_template,direct_template,'//& + 'block_template,cyclic_template,block_cyclic_template,...',line) + +write(*,'(a)') '// Null distribution (mirroring)' + call dcl_uproc(parser,& + 'distribute(dis:null,d:int,t:int,p:int)='//& + 'no_distr(d,t,p)',line) + call dcl_type(parser,'no_distr is rec {_hi:int,_p:int,_pr:int}',line) + call dcl_uproc(parser,'nodes_needed(d:null,g:int)=1',line) + call dcl_uproc(parser,& + 'no_distr(g:int,d:int,p:int)='//& + 'new no_distr {_hi=int(g),_p=int(d),_pr=p}',line) + call dcl_uproc(parser,'#(b:no_distr)=shape([0..b._p-1])',line) + call dcl_uproc(parser,'_shp(b:no_distr)=0..b._p-1',line) + call dcl_uproc(parser,'dims(b:no_distr)=[b._p]',line) + call dcl_uproc(parser,'size(b:no_distr)=b._p',line) + call dcl_uproc(parser,& + 'element(b:no_distr,i:int)=0..b._hi-1',line) + call dcl_uproc(parser,& + 'tile_size(b:no_distr,i:int)=b._hi',line) + call dcl_uproc(parser,'empty(b:no_distr)=1..0',line) + call dcl_uproc(parser,'nodes_for_grid(b:no_distr,g:seq(int))='//& + 'b._pr..b._pr',line) + call dcl_uproc(parser,'node_for(b:no_distr,j:int)=b._pr',line) + call dcl_uproc(parser,'index(b:no_distr,j:int,p:int)=j',line) + call dcl_uproc(parser,'node_nhd(b:no_distr,p:int,d:range(int))=p..p',line) + call dcl_uproc(parser,'node_co_nhd(b:no_distr,p:int,d:range(int))=p..p',line) + +write(*,'(a)') '// Direct distribution (1-1 map to processor topology)' + call dcl_type(parser,'direct_distr is rec {_p:int}',line) + call dcl_type(parser,'direct_template is unique{DIRECT}',line) + call dcl_uproc(parser,& + 'distribute(dis:direct_template,d:int,t:int,p:int)='//& + 'direct_distr(d)',line) + call dcl_uproc(parser,'nodes_needed(d:direct_template,g:int)=g',line) + call dcl_uproc(parser,& + 'direct_distr(d:int)=new direct_distr {_p=int(d)}',line) + call dcl_uproc(parser,'#(b:direct_distr)=shape([0..b._p-1])',line) + call dcl_uproc(parser,'_shp(b:direct_distr)=0..b._p-1',line) + call dcl_uproc(parser,'dims(b:direct_distr)=[b._p]',line) + call dcl_uproc(parser,'size(b:direct_distr)=b._p',line) + call dcl_uproc(parser,& + 'element(b:direct_distr,i:int)=''0..''0',line) + call dcl_uproc(parser,& + 'tile_size(b:direct_distr,i:int)=''1',line) + call dcl_uproc(parser,'empty(b:direct_distr)=''1..''0',line) + call dcl_uproc(parser,'nodes_for_grid(b:direct_distr,g:seq(int))='//& + 'int(g)',line) + call dcl_uproc(parser,'node_for(b:direct_distr,j:int)=j',line) + call dcl_uproc(parser,'index(b:direct_distr,j:int,p:int)=''0',line) + call dcl_uproc(parser,'node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p',line) + call dcl_uproc(parser,'node_co_nhd(b:direct_distr,p:int,d:int or range(int))='//& + '-low(d)+p..-high(d)+p by -1',line) + +write(*,'(a)') '// Variable block distribution' + call dcl_type(parser,'vblock_distr is rec {_hi:int,_p:int}',line) + call dcl_type(parser,'vblock_template is unique{VBLOCK}',line) + call dcl_uproc(parser,& + 'distribute(dis:vblock_template,d:int,t:int,p:int)='//& + 'vblock_distr(d,t)',line) + call dcl_uproc(parser,'nodes_needed(d:vblock_template,g:int)=0',line) + call dcl_uproc(parser,& + 'vblock_distr(g:int,d:int)='//& + 'new vblock_distr {_hi=int(g),_p=int(d)}',line) + call dcl_uproc(parser,'#(b:vblock_distr)=shape([0..b._p-1])',line) + call dcl_uproc(parser,'_shp(b:vblock_distr)=0..b._p-1',line) + call dcl_uproc(parser,'dims(b:vblock_distr)=[b._p]',line) + call dcl_uproc(parser,'size(b:vblock_distr)=b._p',line) + call dcl_uproc(parser,& + 'element(b:vblock_distr,i:int)=start..finish'//& + ' where finish=(ii+1)*b._hi/b._p-1'//& + ' where start=ii*b._hi/b._p where ii=int(i)',line) + call dcl_uproc(parser,& + 'tile_size(b:vblock_distr,i:int)=finish-start+1'//& + ' where finish=(ii+1)*b._hi/b._p-1'//& + ' where start=ii*b._hi/b._p where ii=int(i)',line) + call dcl_uproc(parser,'empty(b:vblock_distr)=1..0',line) + call dcl_uproc(parser,'nodes_for_grid(b:vblock_distr,g:seq(int))='//& + 'lo1..hi1 where'//& + ' lo1=_rdiv(b._p*(low(g)+1)-1,b._hi),'//& + ' hi1=_rdiv(b._p*(high(g)+1)-1,b._hi)',line) + call dcl_uproc(parser,'node_for(b:vblock_distr,j:int)=p'//& + ' where p=_rdiv(b._p*(j+1)-1,b._hi)',line) + call dcl_uproc(parser,'index(b:vblock_distr,j:int,p:int)=i'//& + ' where i=jj-s1'//& + ' where s1=p*b._hi/b._p'//& + ' where jj=int(j)',line) + call dcl_uproc(parser,'_rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y)',line) + call dcl_uproc(parser,'node_nhd(b:vblock_distr,p:int,d:range(int))='//& + 'p+(low(d)-bk+1)/bk..p+(high(d)+bk-1)/bk where bk=b._hi/b._p',line) + +write(*,'(a)') '// fixed block distribution' + call dcl_type(parser,'block_distr is rec {_b:int,_s:int,_p:int}',line) + call dcl_type(parser,'_block_template is rec{block:int}',line) + call dcl_type(parser,'_block_template_default is unique{BLOCK}',line) + call dcl_type(parser,& + 'block_template is _block_template_default,_block_template',line) + call dcl_uproc(parser,& + 'BLOCK(block:int)=new _block_template {block=block}',line) + call dcl_uproc(parser,& + 'distribute(dis:_block_template,d:int,t:int,p:int)='//& + 'block_distr(d,t,dis.block)',line) + call dcl_uproc(parser,& + 'distribute(dis:block_template,d:int,t:int,p:int)='//& + 'block_distr(d,t)',line) + call dcl_uproc(parser,'nodes_needed(d:_block_template,g:int)=(g+d.block)/d.block',line) + call dcl_uproc(parser,'nodes_needed(d:block_template,g:int)=0',line) + call dcl_uproc(parser,& + 'block_distr(s:int,p:int)='//& + 'new block_distr {_b=b,_s=s,_p=p} where b=(s+p-1)/p',line) + call dcl_uproc(parser,& + 'block_distr(s:int,t:int,b:int)='//& + 'new block_distr {_b=b,_s=s,_p=p} where p=(s+b-1)/b',line) + call dcl_uproc(parser,'#(b:block_distr)=shape([0..b._p-1])',line) + call dcl_uproc(parser,'_shp(b:block_distr)=0..b._p-1',line) + call dcl_uproc(parser,'dims(b:block_distr)=[b._p]',line) + call dcl_uproc(parser,'size(b:block_distr)=b._p',line) + call dcl_uproc(parser,& + 'element(b:block_distr,i:int)=start..finish'//& + ' where finish=min(b._s-1,(ii+1)*b._b-1)'//& + ' where start=ii*b._b where ii=int(i)',line) + call dcl_uproc(parser,& + 'tile_size(b:block_distr,i:int)=finish-start+1'//& + ' where finish=min(b._s-1,(ii+1)*b._b-1)'//& + ' where start=ii*b._b where ii=int(i)',line) + call dcl_uproc(parser,& + 'empty(b:block_distr)=1..0',line) + call dcl_uproc(parser,'nodes_for_grid(b:block_distr,g:seq(int))='//& + 'lo1..hi1 where'//& + ' lo1=_rdiv(int(low(g)),b._b),'//& + ' hi1=_rdiv(int(high(g)),b._b)',line) + call dcl_uproc(parser,'node_for(b:block_distr,j:int)=p'//& + ' where p=_rdiv(jj,b._b) where jj=int(j)',line) + call dcl_uproc(parser,'index(b:block_distr,j:int,p:int)=i'//& + ' where i=jj-s1'//& + ' where s1=p*b._b'//& + ' where jj=int(j)',line) + call dcl_uproc(parser,'node_nhd(b:block_distr,p:int,d:range(int))='//& + 'p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b',line) + +write(*,'(a)') '// Cyclic distribution' + call dcl_type(parser,'cyclic_distr is rec {_hi:int,_p:int}',line) + call dcl_type(parser,'cyclic_template is unique{CYCLIC}',line) + call dcl_uproc(parser,& + 'distribute(dis:cyclic_template,d:int,t:int,p:int)='//& + 'cyclic_distr(d,t)',line) + call dcl_uproc(parser,'nodes_needed(d:cyclic_template,g:int)=0',line) + call dcl_uproc(parser,& + 'cyclic_distr(g:int,d:int)='//& + 'new cyclic_distr {_hi=int(g),_p=int(d)}',line) + call dcl_uproc(parser,'#(b:cyclic_distr)=shape([0..b._p-1])',line) + call dcl_uproc(parser,'_shp(b:cyclic_distr)=0..b._p-1',line) + call dcl_uproc(parser,'dims(b:cyclic_distr)=[b._p]',line) + call dcl_uproc(parser,'size(b:cyclic_distr)=b._p',line) + call dcl_uproc(parser,& + 'element(b:cyclic_distr,i:int)='//& + ' int(i)..b._hi-1 by b._p',line) + call dcl_uproc(parser,& + 'tile_size(b:cyclic_distr,i:int)='//& + '(b._hi-1-int(i))/b._p+1',line) + call dcl_uproc(parser,& + 'empty(b:cyclic_distr)=1..0 by 1',line) + call dcl_uproc(parser,'nodes_for_grid(b:cyclic_distr,g:seq(int))='//& + 'cyclic_range(lo,high,p) where high=if(hi-lo>=p=>lo+p-1,hi+if(hi>lo=>0,p))'//& + ' where lo=low(g) mod p,hi=high(g) mod p where p=b._p',& + line) + call dcl_uproc(parser,'node_for(b:cyclic_distr,j:any_int)=p'//& + ' where p=int(j) mod b._p',line) + call dcl_uproc(parser,'index(b:cyclic_distr,j:int,p:int)=int(j)/b._p',line) + call dcl_uproc(parser,'node_nhd(b:cyclic_distr,p:int,d:range(int))='//& + 'cyclic_range(p+low(d),p+high(d),b._p)',line) + +write(*,'(a)') '// Block cyclic distribution' + call dcl_type(parser,& + 'block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int}',line) + call dcl_type(parser,'block_cyclic_template is rec {block:int}',line) + call dcl_uproc(parser,'BLOCK_CYCLIC(block:int)=new block_cyclic_template{block=block}',line) + call dcl_uproc(parser,& + 'distribute(dis:block_cyclic_template,d:int,t:int,p:int)='//& + 'block_cyclic_distr(d,t,dis.block)',line) + call dcl_uproc(parser,'nodes_needed(d:block_cyclic_template,g:int)=0',line) + call dcl_uproc(parser,& + 'block_cyclic_distr(g:int,p:int,b:int)='//& + 'new block_cyclic_distr {_hi=int(g),_p=int(pp),_b=bb,'//& + ' _s=s}'//& + ' where s=pp*bb where bb=if(pp==1=>g,b) where pp=min((g+b-1)/b,p)',line) + call dcl_uproc(parser,'#(b:block_cyclic_distr)=shape([0..b._p-1])',line) + call dcl_uproc(parser,'_shp(b:block_cyclic_distr)=0..b._p-1',line) + call dcl_uproc(parser,'dims(b:block_cyclic_distr)=[b._p]',line) + call dcl_uproc(parser,'size(b:block_cyclic_distr)=b._p',line) + call dcl_uproc(parser,& + 'element(b:block_cyclic_distr,i:int)='//& + ' block_seq(s,b._hi-1,b._s,b._b,0)'//& + ' where s=ii*b._b where ii=int(i)',& + line) + call dcl_uproc(parser,& + 'tile_size(b:block_cyclic_distr,i:int)='//& + 'nc*b._b+max(0,min(b._b,df-nc*b._s)) where nc=df/b._s where df=b._hi-s'//& + ' where s=ii*b._b where ii=int(i)',& + line) + call dcl_uproc(parser,& + 'empty(b:block_cyclic_distr)=block_seq(1,0,1,1,0)',line) + call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:grid_dim)='//& + 'if(hi-lo+1cyclic_range(lo,hi,p),cyclic_range(0,p-1,p))'//& + ' where lo=low(g)/b._b,hi=high(g)/b._b where p=b._p',& + line) + call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:strided_range){'//& + ' var r=0..0;if b._s==step(g) {r=nodes_for_grid(b,low(g)..low(g))} else'//& + ' {r=nodes_for_grid(b,low(g)..high(g))};return r}',line) + call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:block_seq){'//& + ' var r=cyclic_range(0,0,1);if b._s==step(g) {r=nodes_for_grid(b,low(g)..low(g)+width(g)-1)} else'//& + ' {r=nodes_for_grid(b,low(g)..high(g))};return r}',line) + call dcl_uproc(parser,'node_for(b:block_cyclic_distr,j:int)=p'//& + ' where p=_rdiv(jj,b._b) mod b._p where jj=int(j)',line) + call dcl_uproc(parser,'index(b:block_cyclic_distr,j:int,p:int)=i'//& + ' where i=r+b._b*(s-p)'//& + ' where r=j-s*b._s'//& + ' where s=_rdiv(j,b._s)',line) + call dcl_uproc(parser,'node_nhd(b:block_cyclic_distr,p:int,d:range(int))='//& + 'p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b',line) + + call dcl_uproc(parser,'nodes_for_grid(b,g:single_point)=nodes_for_grid(b,g._t..g._t)',line) + +write(*,'(a)') '// Tuple of distributions' + call dcl_uproc(parser,& + 'distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))='//& + 'map($distribute,dis,d,t,p) where p=index2point(_this_node(),t)',line) + call dcl_uproc(parser,& + 'distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))='//& + 'map($distribute,spread(dis,d),d,t,p) where p=index2point(_this_node(),t)',line) + call dcl_uproc(parser,& + 'distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t)',line) + call dcl_uproc(parser,& + 'nodes_needed(b:tuple(distr_template_dim),g:tuple(int))=map($nodes_needed,b,g)',line) + call dcl_uproc(parser,& + 'nodes_needed(b:distr_template_dim,g:tuple(int))=map($nodes_needed,spread(b,g),g)',line) + call dcl_uproc(parser,'node_for(b:tuple(distr_dim),j:tuple(int))='//& + 'map($node_for,b,j)',line) + call dcl_uproc(parser,'#(b:tuple(distr_dim))=shape(map($_shp,b))',line) + call dcl_uproc(parser,'dims(b:tuple(distr_dim))=map($size,b)',line) + call dcl_uproc(parser,'element(b:tuple(distr_dim),i:tuple(int))'//& + '=map($element,b,i)',line) + call dcl_uproc(parser,'element(b:tuple(distr_dim),i:int)='//& + 'element(b,index2point(i,dims(b)))',line) + call dcl_uproc(parser,'tile_size(b:tuple(distr_dim),i:tuple(int))'//& + '=map($tile_size,b,i)',line) + call dcl_uproc(parser,'empty(b:tuple(distr_dim))=map($empty,b)',line) + call dcl_uproc(parser,'nodes_for_grid(b:tuple(distr_dim),g:grid_slice)'//& + '=map($nodes_for_grid,b,g)',line) + call dcl_uproc(parser,'node_num_for(b:tuple(distr_dim),j:tuple(int))'//& + '=index(dims(b),map($node_for,b,j))',line) + call dcl_uproc(parser,'index(b:tuple(distr_dim),j:tuple(int),p:tuple(int))'//& + '=index(tile_size(b,p),map($index,b,j,p))',line) + call dcl_uproc(parser,'node_and_index(b:tuple(distr_dim),j:tuple(int))'//& + '=index(dims(b),p),i where i=index(tile_size(b,p),map($index,b,j,p)) '//& + ' where p=map($node_for,b,j)',line) + call dcl_uproc(parser,'node_and_index(b:distr_dim,j:int)=p,i '//& + 'where i=index(b,j,p) where p=node_for(b,j)',line) + call dcl_uproc(parser,'node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d)',line) + call dcl_uproc(parser,'node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d)',line) + +write(*,'(a)') '// Slice of a tuple of distributions' + call dcl_type(parser,'sliced_distr(t,s) is rec{_t:t,_s:s}',line) + call dcl_uproc(parser,'sliced_distr(t:tuple(distr_dim),s:tuple(seq(int) or single_point(int)))='//& + 'new sliced_distr{_t=t,_s=s}',line) + call dcl_uproc(parser,'node_for(t:sliced_distr,j:tuple(int))=node_for(t._t,t._s[j])',line) + call dcl_uproc(parser,'#(t:sliced_distr)=#t._t',line) + call dcl_uproc(parser,'dims(t:sliced_distr)=dims(t._t)',line) + call dcl_uproc(parser,'element(t:sliced_distr,i:tuple(int) or int)=overlap(t._s,element(t._t,i))',line) + call dcl_uproc(parser,'tile_size(t:sliced_distr,i:tuple(int) or int)=dims(element(t,i))',line) + call dcl_uproc(parser,'empty(t:sliced_distr)=new sliced_distr{_t=empty(t._t),_s=t._s}',line) + call dcl_uproc(parser,'nodes_for_grid(t:sliced_distr,g:grid)=nodes_for_grid(t._t,t._s[g])',line) + call dcl_uproc(parser,'node_num_for(t:sliced_distr,j:tuple(int))'//& + '=node_num_for(t._t,t._s[j])',line) + call dcl_uproc(parser,'index(t:sliced_distr,j:tuple(int),p:tuple(int))='//& + 'index(tile_size(t,p),element(t,p)#j)',line) + call dcl_uproc(parser,'node_and_index(t:sliced_distr,j:int)=p,i'//& + ' where i=index(t,j,p) where p=node_for(t,j)',line) + call dcl_uproc(parser,'node_nhd(t:sliced_distr,p:tuple,d:tuple)=node_nhd(t._t,p,_stpmult(d,t._s))',line) + call dcl_uproc(parser,'node_co_nhd(t:sliced_distr,p:tuple,d:tuple)=node_co_nhd(t._t,p,_stpmult(d,t._s))',line) + call dcl_uproc(parser,'_stpmult(d:tuple,s:tuple)=map($_stpmult,d,s)',line) + call dcl_uproc(parser,'_stpmult(d:range,s:range)=d',line) + call dcl_uproc(parser,& + '_stpmult(d:range,s:strided_range)=if(st>0=>st*low(d)..st*high(d),st*high(d)..st*low(d)) where st=step(s)',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// SUPPORT FOR PARALLEL STATEMENTS' +write(*,'(a)') '// *****************************************' + +write(*,'(a)') '// Get and set elements in "for"' + call dcl_uproc(parser,'PM__getelem(x:grid_slice_dim or cyclic_range,y)=element(x,y)',line) + call dcl_uproc(parser,'PM__getelem(x:grid_slice or iterable_grid,y)=element(x,y)',line) + call dcl_uproc(parser,'PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t))',line) + call dcl_uproc(parser,'PM__getelem(a:array_slice(any^any,),y)=element(a,y)',line) + call dcl_uproc(parser,'PM__getelem(x:array_template,y)=x._a',line) + call dcl_uproc(parser,'PM__getelem(a:any^dshape,t)=element(a,(#a)[t])',line) + + call dcl_uproc(parser,'PM__setelem(&x,v,y) {_set_elem(&x,v,(#x)[y])}',line) + call dcl_uproc(parser,'PM__setelem(&a:any^mshape,v,t:index)'//& + '{ PM__setaelem(&a,index(dims(a),t),v) }',line) + call dcl_uproc(parser,'PM__setelem(&a:any^dshape,v,t:index) {'//& + ' PM__setaelem(&a,i,v) check p==_this_node() '//& + ' where p,i=node_and_index((#a).dist,_tup(t)) }',line) + call dcl_uproc(parser,'PM__setelem(&a:array_slice(any^any,),v,t:index) {'//& + ' _set_elem(&a._a,v,a._s[t]) }',line) + + call dcl_uproc(parser,'PM__get_elem%(x,i,h)=PM__getelem(x,h)',line) + call dcl_uproc(parser,'PM__set_elem%(&x:invar,v:complete,i,h)'//& + '{PM__setelem(&x,v,h <>);_assemble%(&x,region)}',line) + + call dcl_uproc(parser,'PM__get_elem%(x:shared any^dshape,i,h)='//& + 'element(PM__local(x),i)',line) + call dcl_uproc(parser,'PM__set_elem%(&x:invar any^dshape,v:complete,i,h) '//& + '{_set_elem(&^(PM__local(^(&x))),v,i <>)}',line) + + call dcl_uproc(parser,'PM__get_elem%(x:shared array_slice(any^dshape),j,h)='//& + '_get_aelem(x._a,i) check p==_this_node() '//& + ' where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h])',line) !!!!! + call dcl_uproc(parser,'PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){'//& + 'PM__setaelem(&x._a,i,v <>) check p==_this_node() '//& + ' where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) }',line) !!! + + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar mshape) {}',line) + + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) {}',line) + + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar) shared <> {'//& + ' dist=xregion.dist; '//& + ' foreach p in #(dist) {'//& + ' tile=dist[p];'//& + ' i=index(dims(dist),p);'//& + ' if i==_this_node() {'//& + ' forall j in tile { '//& + ' var k=PM__getelem(a,j); '//& + ' PM__broadcast(&k,i)'//& + ' };'//& + ' } else { '//& + ' forall j in tile { '//& + ' var k=_arb(a);'//& + ' PM__broadcast(&k,i);'//& + ' PM__setelem(&a,k,j <>)'//& + ' }'//& + ' }'//& + ' } }',& + line) + + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> {'//& + ' dist=xregion.dist; '//& + ' foreach p in #(dist) {'//& + ' tile=intersect((#(a._a))#a._s,dist[p]);'//& + ' i=index(dims(dist),p);'//& + ' if i==_this_node() {'//& + ' forall j in tile { '//& + ' var k=PM__getelem(a._a,j); '//& + ' PM__broadcast(&k,i)'//& + ' };'//& + ' } else { '//& + ' forall j in tile { '//& + ' var k=_arb(a._a);'//& + ' PM__broadcast(&k,i);'//& + ' PM__setelem(&a._a,k,j <>)'//& + ' }'//& + ' }'//& + ' } }',& + line) + +write(*,'(a)') '// Support for % procs' + call dcl_uproc(parser,'PM__get_tilesz(d)=d._tile,d._size',line) + call dcl_uproc(parser,'PM__get_tilesz(d:mshape)=d,size(d)',line) + +write(*,'(a)') '// Support for ! operator' + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,& + 'PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region))',line) + call dcl_uproc(parser,& + 'PM__makearray%(x:priv)=_makearray(x,region,size(region))'//& + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) + call dcl_uproc(parser,& + 'PM__makearray%(x:invar)=_makearray(x,region,size(region))'//& + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) + call dcl_proc(parser,& + '_makearray(x:any,y:any,z:any)->PM__invar_dim x,y',& + "make_array",0,line,proc_needs_type) +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,& + 'PM__makearray%(x:chan) complete <>=_makearray(x,region)',line) + call dcl_uproc(parser,& + 'PM__makearray%(x:priv)=_makearray(x,region)'//& + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) + call dcl_uproc(parser,& + 'PM__makearray%(x:invar)=_makearray(x,region)'//& + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) + call dcl_proc(parser,& + '_makearray(x:any,y:any)->PM__dim x,y',& + "make_array",0,line,proc_needs_type) +!!$ call dcl_uproc(parser,'PM__correctarray(x)=_redim(PM__export +write(*,'(a)') 'PM__endif' + +write(*,'(a)') '// active%() intrinsic' + call dcl_uproc(parser,'active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>)',line) + call dcl_uproc(parser,'_masked%(x) complete <>=masked(x)',line) + call dcl_uproc(parser,'active%()=^(^??,coherent)',line) + call dcl_proc(parser,'PM__active()->bool',"active",0,line,0) + +write(*,'(a)') '// Imports and exports' + call dcl_proc(parser,'_import_val(x:any)->=x',& + "import_val",0,line,0) + call dcl_proc(parser,'PM__importshrd(x:any)->=x',& + "import_val",0,line,0) + call dcl_proc(parser,'PM__importvarg(x:any)->=x',& + "import_varg",0,line,proc_is_not_inlinable) + call dcl_proc(parser,'_import_scalar(x:any)->invar x',& + "import_scalar",0,line,0) + call dcl_uproc(parser,'PM__import_val(x) {PM__checkimp(x);return _import_val(x)}',line) + call dcl_uproc(parser,'PM__impscalar(x) {PM__checkimp(x);return _import_scalar(x)}',line) + call dcl_uproc(parser,'PM__import_val(x:^*(,,,,)) {'//& + 'test "Compiler internal error:importing reference" => ''false;return x}',line) + call dcl_uproc(parser,'PM__impscalar(x:^*(,,,,)) {'//& + 'test "Compiler internal error:importing reference" => ''false;return x}',line) + + call dcl_uproc(parser,'PM__checkimp(x,arg...) {PM__checkimp(x);PM__checkimp(arg...)}',line) + call dcl_uproc(parser,'PM__checkimp(x) {}',line) + call dcl_uproc(parser,'PM__checkimp(x:contains(PM__distr_tag)) {'//& + 'test "Cannot import a distributed value into a nested parallel scope" => ''false}',& + line) + + call dcl_type(parser,'schedule(subregion,blocking) is '//& + 'rec{_subregion:subregion,_subtile,_blocking:blocking}',line) + call dcl_uproc(parser,'subregion(schedule:schedule)=schedule._subregion',line) + call dcl_uproc(parser,'subregion(schedule:null)=null',line) + call dcl_uproc(parser,'subtile(schedule:schedule)=schedule._subtile',line) + +write(*,'(a)') '// Over statements' + call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar) shared <>='//& + 'new schedule{_subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region)}',line) + call dcl_uproc(parser,'PM__over%(x:invar,block:invar) shared <>='//& + 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& + 'where s=intersect(x,schedule._subregion)',line) + call dcl_uproc(parser,'PM__make_over%(schedule:null,'//& + 'x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>='//& + 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& + 'check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s '//& + 'where s=fill_in(region._extent,x,null)',line) + call dcl_uproc(parser,'PM__make_over%(x:invar tuple(subs_dim except stretch_dim)'//& + ',block:invar) shared <>='//& + 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& + 'where s=intersect(map($norm,fill_in(region._extent,x,''true)),schedule._subregion)',line) + call dcl_uproc(parser,'PM__make_over%(x:invar,block)=x'//& + ' check "Expression in an ""over"" statement must be a subscript tuple"=>''false',line) + call dcl_uproc(parser,'PM__make_over%(x,block)=x'//& + ' check "Expression in an ""over"" statement must be ""invar"""=>''false',line) + + call dcl_uproc(parser,'_blocking(b:tuple(any_int),region)=int(b) {'//& + 'test "Blocking factor must have same rank as current region"=>'//& + ' rank(b)==rank(extent(region))}',& + line) + call dcl_uproc(parser,'_blocking(b,region)=null {'//& + 'test "Blocking factor must be a tuple of integers"=>''false}',line) + call dcl_uproc(parser,'_blocking(b:null,region)=null',line) + + + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'PM__do_over(x:null,region)=x',line) + call dcl_uproc(parser,'PM__do_over(x:schedule,region)='//& + '_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking)',line) + call dcl_uproc(parser,'_do_elem(x:range(int))=_st(low(x),high(x))',line) + call dcl_uproc(parser,'_do_elem(x:strided_range(int))=_st(low(x),high(x),step(x))',line) + call dcl_uproc(parser,'_do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x))',line) + call dcl_uproc(parser,'_do_elem(x:map_seq)=_st(x.array,size(x.array),null,null)',line) + call dcl_uproc(parser,'_do_elem(x:single_point)=_st(x._t)',line) + call dcl_uproc(parser,'PM__nested_loop(x:null){}',line) + call dcl_proc(parser,'PM__nested_loop(any)',"nested_loop",0,line,0) + call dcl_uproc(parser,'_ldims(x:mshape)=map_apply($size,$_st,x._extent)',line) + call dcl_uproc(parser,'_ldims(x:dshape)=map_apply($size,$_st,x._tile)',line) +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,'PM__do_over%(x:null)=true',line) + call dcl_uproc(parser,'PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion',line) + call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) + call dcl_uproc(parser,'PM__do_over%(x:invar grid) complete <>'//& + '{chan var t=false;'//& + ' _in%(x,&^(PM__local(^(&t!))) <>);'//& + ' return t}',line) + call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) + call dcl_uproc(parser,'_in%(x:invar,&t:invar) shared <>{forall i in x {sync t[i]=true}}',line) +write(*,'(a)') 'PM__endif' + +write(*,'(a)') '// Parallel processing inquiry' + call dcl_proc(parser,'_sys_node()->int',"sys_node",0,line,0) + call dcl_proc(parser,'sys_nnode()->int',"sys_nnode",0,line,0) + call dcl_proc(parser,'_this_node()->int',"this_node",1,line,0) + call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->int',"this_node",2,line,0) + call dcl_proc(parser,'this_nnode()->int',"this_nnode",0,line,0) + call dcl_proc(parser,'_shrd_node()->int',"shared_node",0,line,0) + call dcl_proc(parser,'shrd_nnode()->int',"shared_nnode",0,line,0) + call dcl_proc(parser,'_root_node()->int',"root_node",0,line,0) + call dcl_proc(parser,'is_shrd()->bool',"is_shared",0,line,0) + call dcl_proc(parser,'is_shrd(any)->bool',"is_shared",0,line,0) + call dcl_proc(parser,'is_par()->bool',"is_par",0,line,0) + call dcl_uproc(parser,'_head_node()=_shrd_node()==0',line) + +write(*,'(a)') '// Parallel system nested contexts' + call dcl_proc(parser,'_push_node_grid(arg...:any)',& + "push_node_grid",0,line,proc_is_impure+proc_has_for) + call dcl_uproc(parser,'_push_node(d:int,t:int){'//& + '_push_node_grid(false,t)}',line) + call dcl_uproc(parser,'_push_node(d:tuple1d,t:tuple1d,e:tuple1d) { '//& + '_push_node_grid(is_cyclic(e.1),t.1) }',line) + call dcl_uproc(parser,'_push_node(d:tuple2d,t:tuple2d,e:tuple2d) { '//& + '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),t.1,t.2) }',& + line) + call dcl_uproc(parser,'_push_node(d:tuple3d,t:tuple3d,e:tuple3d) { '//& + '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& + 't.1,t.2,t.3) }',line) + call dcl_uproc(parser,'_push_node(d:tuple4d,t:tuple4d,e:tuple4d) { '//& + '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& + 'is_cyclic(e.4),'//& + 't.1,t.2,t.3,t.4) }',line) + call dcl_uproc(parser,'_push_node(d:tuple5d,t:tuple5d,e:tuple5d) { '//& + '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& + 'is_cyclic(e.4),is_cyclic(e.5),'//& + 't.1,t.2,t.3,t.4,t.5) }',line) + call dcl_uproc(parser,'_push_node(d:tuple6d,t:tuple6d,e:tuple6d) { '//& + '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& + 'is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),'//& + 't.1,t.2,t.3,t.4,t.5,t.6) }',line) + call dcl_uproc(parser,'_push_node(d:tuple7d,t:tuple7d,e:tuple7) { '//& + '_push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),'//& + 'is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),'//& + 't.1,t.2,t.3,t.4,t.5,t.6,t.7) }',line) + + call dcl_proc(parser,'_push_node_split(int)',"push_node_split",& + 0,& + line,proc_is_impure+proc_has_for) + call dcl_proc(parser,'_push_node_conc()',"push_node_conc",0,& + line,0) + call dcl_uproc(parser,'PM_pop_node(x:mshape) {}',line) + call dcl_proc(parser,'PM_pop_node(x:shape)',"pop_node",0,line,0) + call dcl_proc(parser,'PM_pop_conc(bool)',"pop_node_conc",& + 0,line,0) + call dcl_proc(parser,'_push_node_dist()',"push_node_distr",0,line,proc_is_impure+proc_has_for) + call dcl_uproc(parser,'_lvl()=1',line) + + +write(*,'(a)') '// ************************************************' +WRITE(*,'(A)') '// PROCESSOR ALLOCATION' +write(*,'(a)') '// ************************************************' + +!!$ call dcl_uproc(parser,& +!!$ 'PM__partition(pp:null,dd:dshape)='//& +!!$ ' dd._tile,#dd._mshape,null',line) + call dcl_uproc(parser,& + 'PM__partition(pp,d:dshape) {'//& + '_push_node_dist();return dd._tile,dd,null where dd=new dshape {_mshape=#d._mshape,dist=d.dist,'//& + '_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level'//& + '}}',line) + call dcl_uproc(parser,& + 'PM__partition(pp,d:dshape,distr:null,topo:null,simplify:null,work:null,sched,block) {'//& + '_push_node_dist();return dd._tile,dd,_block_schedule(block,dd)'//& + ' where dd=new dshape {_mshape=#d._mshape,dist=d.dist,'//& + ' _tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level'//& + '}}',line) + call dcl_uproc(parser,& + 'PM__partition(pp,d:dshape,distr,topo,simplify,work,sched,block) {'//& + 'test "Cannot have attributes in ""for""statement over distributed value" => ''false;'//& + 'return dd._tile,dd,null where dd=new dshape {_mshape=##d,dist=d.dist,'//& + '_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level'//& + '}}',& + line) + call dcl_uproc(parser,'PM__partition(pp,d:mshape)=tile,shape,sched'//& + ' where tile,shape,sched='//& + ' PM__partition(pp,d,null,null,null,null,null,null)',line) + call dcl_uproc(parser,& + 'PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) {'//& + ' d=dims(mshape);topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode()));'//& + ' var p=_shrd_node();'//& + ' dist=distribute(distr,d,topol);'//& + ' s=size(#(dist));np=shrd_nnode(); '//& + ' test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np;'//& + ' if s=s { '//& + ' p=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) '//& + ' };'//& + ' _push_node_split(p) '//& + ' } else { '//& + ' _push_node_dist()'//& + ' }; '//& + ' elem=element(dist,p); elemsz=#elem; '//& + ' dd=new dshape {_mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz,'//& + ' _size=size(elemsz),_level=_lvl()};'//& + 'return dd._tile,dd,_block_schedule(block,dd) }',line) + call dcl_uproc(parser,& + 'PM__partition(pp:null,d:mshape,distr,topo,simplify,work,sched,block)='//& + '#d._extent,#d,_block_schedule(block,#d)',line) + call dcl_uproc(parser,& + 'PM__partition(pp:null,d:dshape,distr,topo,simplify,work,sched,block)='//& + '#d._extent,#d._mshape,_block_schedule(block,#d._mshape)',line) + + call dcl_uproc(parser,'_block_schedule(block:null,region)=null',line) + call dcl_uproc(parser,'_block_schedule(block,region)='//& + 'new schedule{_subregion=region,_subtile=region._tile,_blocking=_blocking(block,region)}',line) + + call dcl_uproc(parser,& + 'workshare(work:null,d,dist,nnode:int,'//& + 'snode:int,nsnode:int)='//& + 'nnode*(2*snode+1)/(2*nsnode)',line) + call dcl_uproc(parser,& + 'workshare(work:array(int),d,dist,nnode:int,snode:int,nsnode:int) { '//& + 'test "work array does not conform to mshape"=>'//& + 'conform(#work,#d); '//& + 'var wk=work;return _wshare(wk,nnode,snode,nsnode) }',line) + call dcl_proc(parser,& + '_wshare(int^any,int,int,int)->int',"wshare",0,line,0) + +write(*,'(a)') '// *************************************************************' +WRITE(*,'(A)') '// I/O OPERATIONS' +write(*,'(a)') '// *************************************************************' + +write(*,'(a)') '// Built-in operators' + call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->sint,sint',& + "open_file",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_close_file(sint)->sint',& + "close_file",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_seek_file(sint,lint)->sint',& + "seek_file",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_read_file(sint,&any)->sint',& + "read_file",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_write_file(sint,any)->sint',& + "write_file",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_read_file_array(sint,&any,int)->sint',& + "read_file_array",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_write_file_array(sint,any,int)->sint',& + "write_file_array",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->sint',& + "read_file_tile",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->sint',& + "write_file_tile",0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_io_error_string(sint)->string',& + "io_error_string",0,line,proc_is_impure) + +write(*,'(a)') '// IO/related types' + call dcl_type(parser,'io_type is num,bool',line) + call dcl_type(parser,'filesystem is rec{_tag:PM__distr_tag}',line) + call dcl_type(parser,'file is struct {_f:sint,_tag:PM__distr_tag}',line) + call dcl_type(parser,'io_error is rec {_errno:sint,use _iserr:bool}',line) + call dcl_uproc(parser,'PM__filesys()=new filesystem{}',line) +!write(*,'(a)') '// call dcl_uproc(parser,'PM__filesys()=0',line)' + +write(*,'(a)') '// Basic operations' + call dcl_uproc(parser,'open(&filesystem:filesystem,name,'//& + 'append=false,create=false,temp=false,'//& + 'excl=false,read=false,write=false,seq=false)=new file {_f=f},_make_file_error(err) '//& + 'where f,err=_open_file(name,append,create,'//& + 'temp,excl,read,write,seq)',line) + call dcl_uproc(parser,'_make_file_error(x:sint)=new io_error {_errno=x,_iserr=x/=0}',line) + call dcl_uproc(parser,'close(&f:file)'//& + '{err=_close_file(f._f);return _make_file_error(err)}',line) + call dcl_uproc(parser,'seek(&f:file,j:lint)'//& + '{err=_seek_file(f._f,j);return _make_file_error(err)}',line) + call dcl_uproc(parser,'read(&f:file,&x:io_type)'//& + '{err=_read_file(f._f,&x);return _make_file_error(err)}',line) + call dcl_uproc(parser,'write(&f:file,x:io_type)'//& + '{err=_write_file(f._f,x);return _make_file_error(err)}',line) + +write(*,'(a)') '// Array I/O' + call dcl_uproc(parser,& + 'read(&f:file,&x:io_type^mshape)'//& + '{err=_read_file_array(f._f,&x,size(x));return _make_file_error(err)}',line) + call dcl_uproc(parser,& + 'write(&f:file,x:io_type^mshape)'//& + '{err=_write_file_array(f._f,x,size(x));return _make_file_error(err)}',line) + call dcl_uproc(parser,& + 'read(&f:file,&x:io_type^dshape) '//& + '{var err=_make_file_error(0''s);for i in x:err=read%(&f,&i);return err}',& + line) + call dcl_uproc(parser,& + 'write(&f:file,x:io_type^dshape) '//& + '{var err=_make_file_error(0''s);for i in x:err=write%(&f,i)}',line) + +write(*,'(a)') '// Distributed I/O' + call dcl_uproc(parser,'partition%(f:filesystem)=f:test "Partition not yet implemented"=>''false',line) + call dcl_uproc(parser,& + 'read%(&f:shared file,&x:complete io_type)'//& + '{err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape));'//& + 'return _make_file_error(err)}',line) + call dcl_uproc(parser,& + 'write%(&f:shared file,x:complete io_type)'//& + '{err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape));'//& + 'return _make_file_error(err)}',line) + +write(*,'(a)') '// Error trapping versions of I/O routines' + call dcl_uproc(parser,'string(error:io_error)=_io_error_string(error._errno)',line) + call dcl_uproc(parser,'open(&f:filesystem,name:string,key...) {file,error=open(&f,name,key...);'//& + ' test "Error opening file """++name++""": "++error=>not(error);return file}',line) + call dcl_uproc(parser,'close(&f:file) '//& + '{error=close(&f);test "Error closing file:"++error=>not(error)}',line) + call dcl_uproc(parser,'read(&f:file,&x) '//& + '{error=read(&f,&x);test "Error reading from file:"++error=>not(error)}',line) + call dcl_uproc(parser,'write(&f:file,x) '//& + '{error=write(&f,x);test "Error writing to file:"++error=>not(error)}',line) + call dcl_uproc(parser,'seek(&f:file,x:lint) '//& + '{error=seek(&f,x);test "Error on seek:"++error=>not(error)}',line) + call dcl_uproc(parser,'read%(&f:shared file,&x) '//& + '{error=read%(&f,&x);test "Error reading from file:"++error=>not(error)}',line) + call dcl_uproc(parser,'write%(&f:shared file,x) '//& + '{error=write%(&f,x);test "Error writing to file:"=>not(error)}',line) + +write(*,'(a)') '// *************************************************************' +WRITE(*,'(A)') '// SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS' +write(*,'(a)') '// *************************************************************' + +write(*,'(a)') '// SOA tuples' + call dcl_type(parser,'_stuple1d is rec^{t1}',line) + call dcl_type(parser,'_stuple2d is rec^{t1,t2}',line) + call dcl_type(parser,'_stuple3d is rec^{t1,t2,t3}',line) + call dcl_type(parser,'_stuple4d is rec^{t1,t2,t3,t4}',line) + call dcl_type(parser,'_stuple5d is rec^{t1,t2,t3,t4,t5}',line) + call dcl_type(parser,'_stuple6d is rec^{t1,t2,t3,t4,t5,t6}',line) + call dcl_type(parser,'_stuple7d is rec^{t1,t2,t3,t4,t5,t6,t7}',line) + + call dcl_uproc(parser,& + '_st(t1)=new _stuple1d{t1=t1}',line) + call dcl_uproc(parser,& + '_st(t1,t2)=new _stuple2d{t1=t1,t2=t2}',line) + call dcl_uproc(parser,& + '_st(t1,t2,t3)=new _stuple3d{t1=t1,t2=t2,t3=t3}',line) + call dcl_uproc(parser,& + '_st(t1,t2,t3,t4)=new _stuple4d{t1=t1,t2=t2,t3=t3,t4=t4}',line) + call dcl_uproc(parser,& + '_st(t1,t2,t3,t4,t5)=new _stuple5d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5}',line) + call dcl_uproc(parser,& + '_st(t1,t2,t3,t4,t5,t6)=new _stuple6d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6}',line) + call dcl_uproc(parser,& + '_st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7}',line) + +write(*,'(a)') '// Create normalised form of a grid used for _xxx_slice operations' + call dcl_uproc(parser,'_norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x))',line) + call dcl_uproc(parser,'_norm(n,x:map_seq)=_st(x.array,n)',line) + call dcl_uproc(parser,'_norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x))',line) + +write(*,'(a)') '// Apply idxdim index and convert to normal for for _send_slice_mapped' + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:single_point)='//& + '_st(m,t,t,1,1,0) where t=_dmap(x,n._t)',line) + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:range)='//& + '_st(m,_dmap(x,n._lo),_dmap(x,n._hi),1,1,0)',line) + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:strided_range)='//& + '_st(m,_dmap(x,n._lo),_dmap(x,n._hi),x._st*n._m,1,0)',line) + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1,''1),m,n:block_seq)='//& + '_st(m,n._lo+x._c,n._hi+x._c,n._st,n._b,n._align)',line) + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:block_seq)='//& + '_dnorm(x,m,map_seq(n))',line) + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:map_seq){'//& + 'var a=array(0,#n._array);forall i in a,j in n._array:i=_dmap(x,j);return _st(a)}',line) + call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:grid)='//& + '_st(map_apply($_dnorm,$_st,x,m,n),size(n))',line) + +!!$ call dcl_type(parser,'_griddef is rec^{grid,elems,size}',line) +!!$ call dcl_uproc(parser,'_gd(grid,elems,size)=new _griddef{grid=grid,elems=elems,size=size}',line) + + call dcl_type(parser,'_griddef is rec^{grid,elems}',line) + call dcl_uproc(parser,'_gd(grid,elems,size)=new _griddef{grid=grid,elems=elems}',line) + + call dcl_uproc(parser,& + '_send_slice(p,x:_comp^any,d) { '//& + 'forall i in d { _isend_offset%(j,p,x) '//& + 'where j=index(#x,i) } }',line) + call dcl_uproc(parser,& + '_send_slice(p,x,d) { '//& + '_isend_offset(_norm(dims(x),d),p,x) }',line) + call dcl_uproc(parser,& + '_send_slice_mapped(p,x,d,t,s) { '//& + 'forall k in d { _isend_offset%(j,p,x) '//& + 'where j=index(dims(s),s#i) where i=_dmap(t,k)}}',line) + call dcl_uproc(parser,& + '_send_slice_mapped(p,x:_comp^any,d,t:indexed_dim(''1),s) { '//& + 'forall k in d { _isend_offset%(j,p,x) '//& + 'where j=index(dims(s),s#i) where i=_dmap(t,k)}}',line) + call dcl_uproc(parser,& + '_send_slice_mapped(p,x,d,t:indexed_dim(''1),s) { '//& + '_isend_offset(_dnorm(t,dims(x),d),p,x)}',line) + + call dcl_uproc(parser,& + '_recv_slice(p,&x:_comp^any,d) { '//& + 'forall i in d { _irecv_offset%(j,p,&x) '//& + 'where j=index(#x,i) } }',line) + call dcl_uproc(parser,& + '_recv_slice(p,&x,d) { '//& + '_irecv_offset(_norm(dims(x),d),p,&x) }',line) + call dcl_uproc(parser,& + '_recv_slice_sync(p,&x:_comp^any,d) { '//& + 'forall i in d { _recv_offset%(j,p,&x) '//& + 'where j=index(#x,i) } }',line) + call dcl_uproc(parser,& + '_recv_slice_sync(p,&x,d) { '//& + '_recv_offset(_norm(dims(x),d),p,&x) }',line) + call dcl_uproc(parser,'_bcast_slice_shared(&x,d){_bcast_shared_offset(_norm(dims(x),d),&x)}',line) +!!$ call dcl_uproc(parser,& +!!$ '_recv_slice_resend(p,&x:_comp^any,d) { '//& +!!$ 'forall i in d { _recv_resend%(j,p,&x) '//& +!!$ 'where j=index(#x,i) } }',line) +!!$ call dcl_uproc(parser,& +!!$ '_recv_slice_resend(p,&x,d) { '//& +!!$ '_recv_resend(_norm(dims(x),d),p,&x) }',line) + call dcl_uproc(parser,& + '_send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^(''true)) {'//& + 'forall i in d { j=index(sx,i);'//& + '_isend_recv_req%(j,p,^(x),&^(^(a))); '//& + '} }',line) + call dcl_uproc(parser,& + '_send_recv_slice_req(p,x,&a,sx,d,c:^^(''true)) {'//& + '_isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a)))}',line) + call dcl_uproc(parser,& + '_send_recv_slice_req(p,x,&a,sx,d,c) {'//& + 'forall i in d { j=index(sx,i);_isend_recv_req%(j,p,^(x),&^(^(a)),c) '//& + '} }',line) + call dcl_uproc(parser,& + '_send_slice_assn(p,x:_comp,y,sx,d,c:^^(''true)) {'//& + 'forall i in d { _isend_assn%(j,^(p),^(x),^(y)) '//& + 'where j=index(sx,i) } }',line) + call dcl_uproc(parser,& + '_send_slice_assn(p,x,y,sx,d,c:^^(''true)) {'//& + '_isend_assn(_norm(dims(sx),d),p,x,y)}',line) + call dcl_uproc(parser,& + '_send_slice_assn(p,x,y,sx,d,c) {'//& + 'forall i in d { _isend_assn%(j,p,^(x),^(y),^(c)) '//& + 'where j=index(sx,i) } }',line) + call dcl_uproc(parser,& + '_recv_slice_reply(p,&x:_comp,sx,d,c:^^(''true)) {'//& + 'forall i in d { _recv_reply%(j,^(p),&^(^(x))) '//& + 'where j=index(sx,i) } }',line) + call dcl_uproc(parser,& + '_recv_slice_reply(p,&x,sx,d,c:^^(''true)) {'//& + '_recv_reply(_norm(dims(sx),d),p,&x) }',line) + call dcl_uproc(parser,& + '_recv_slice_reply(p,&x,sx,d,c) {'//& + 'forall i in d { _recv_reply%(j,p,&^(^(x)),c) '//& + 'where j=index(sx,i) } }',line) + + +!!$ call dcl_uproc(parser,& +!!$ '_bcast_slice(&x:_comp,sx,d,c:''true) {'//& +!!$ 'forall i in d { _bcast_slice_shared%(_gd(_norm(dims(sx),d),j,size(d)),_head_node(),&^(^(x))) '//& +!!$ 'where j=index(sx,i) } }',line) +!!$ call dcl_uproc(parser,& +!!$ '_bcast_slice(&x,sx,d,c:''true) {'//& +!!$ '_bcast_slice_shared(_gd(_norm(dims(sx),d),null,size(d)),_head_node(),&^(^(x)))}',line) +!!$ call dcl_uproc(parser,& +!!$ '_bcast_slice_shared(&x,sx,d,c) {'//& +!!$ 'forall i in d { _bcast_slice_shared%(j,_head_node(),&^(^(x)),c) '//& +!!$ 'where j=index(sx,i) } }',line) + + call dcl_proc(parser,'_isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any)',& + "isend_offset",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_offset(j:any,p:any,x:any)',& + "isend_grid",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any)',& + "irecv_offset",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_irecv_offset(j:any,p:any,&x:any)',& + "irecv_grid",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any)',& + "recv_offset",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_recv_offset(j:any,p:any,&x:any)',& + "recv_grid",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_bcast_shared_offset%(r:any,s:any,h:any,j:any,&x:any)',& + "bcast_shared_offset",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_bcast_shared_offset(j:any,&x:any)',& + "bcast_shared_grid",0,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_recv_resend%(r:any,s:any,h:any,j:any,p:any,&x:any)',& +!!$ "recv_offset_resend",1,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_recv_resend(j:any,p:any,&x:any)',& +!!$ "recv_grid_resend",1,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend(p:any,x:any)',& + "isend",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_irecv(p:any,&x:any)',& + "irecv",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_recv(p:any,&x:any)',& + "recv",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any)',& + "isend_req",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_recv_req(j:any,p:any,x:any,&a:any)',& + "isend_req",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any)',& + "isend_req",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any)',& + "isend_assn",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_assn(j:any,p:any,x:any,y:any)',& + "isend_assn",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any)',& + "isend_assn",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& + "recv_reply",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any)',& + "recv_reply",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_recv_reply(j:any,p:any,&x:any)',& + "recv_reply",0,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& +!!$ "broadcast_disp",1,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any)',& +!!$ "broadcast_disp",1,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_bcast_slice_shared(j:any,p:any,&x:any)',& +!!$ "broadcast_disp",1,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_bcast_shared(&x:any)',"broadcast_shared",0,line,proc_is_impure) + call dcl_proc(parser,'_bcast_shared(&x:any,p:int)',"broadcast_shared",0,line,proc_is_impure) + + call dcl_type(parser,'_ct is array_slice,^*(,,,,),any^any,^^(any)',line) + + call dcl_uproc(parser,'PM__sync_messages(x)<>:_sync_messages(x)',line) + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'_sync_messages(x:_ct):_do_sync_messages(_core(x))',line) + call dcl_uproc(parser,'_sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y))',line) + call dcl_uproc(parser,'_core(x:any^any)=x',line) + call dcl_uproc(parser,'_core(x:^^(any))=x',line) + call dcl_uproc(parser,'_core(x:array_slice)=_core(x._a)',line) + call dcl_uproc(parser,'_core(x:^*(,,,,))=_core(_v2(x))',line) + call dcl_proc(parser,& + '_do_sync_messages(arg...:^^(any) or any^any)',& + "sync_mess",0,line,proc_is_impure+proc_is_dcomm) +write(*,'(a)') 'PM__else' + call dcl_proc(parser,& + '_sync_messages(arg...:_ct)',& + "sync_mess",0,line,proc_is_impure+proc_is_dcomm) +write(*,'(a)') 'PM__endif' + call dcl_uproc(parser,'_tup(x:tuple)=x',line) + call dcl_uproc(parser,'_tup(arg...)=tuple(arg...)',line) + call dcl_uproc(parser,'_tup(x:null)=x',line) + call dcl_uproc(parser,'_tup%(x:invar) shared=_tup(x)',line) + + call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',"broadcast",& + 0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'PM__broadcast(b:any,a:int)->=b',"broadcast_val",& + 0,line,proc_is_impure+proc_is_dcomm) + + call dcl_proc(parser,& + 'get_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& + 'b:int,c:int)->%a',& + "get_remote_distr",& + 0,line,proc_is_impure+proc_is_dcomm) + + call dcl_proc(parser,& + 'put_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& + 'b:any,c:int,d:int)',& + "put_remote_distr",& + 0,line,proc_is_impure+proc_is_dcomm) + +write(*,'(a)') '// ********************************************************' +WRITE(*,'(A)') '// OTHER COMMUNICATING & ARRAY OPERATIONS' +write(*,'(a)') '// ********************************************************' + + call dcl_uproc(parser,'map(p:proc,x:any^any) {var z=array(p.(_arb(x)),#x);for i in z, j in x:i=p.(j)}',line) + call dcl_uproc(parser,'map(p:proc,x:any^any,y:any^any) '//& + '{var z=array(p.(_arb(x),_arb(y)),#x);for i in z,j in x,k in y:i=p.(j,k)}',line) + call dcl_uproc(parser,'map(p:proc,x:any^mshape,y:any^dshape) '//& + '{var z=array(p.(_arb(x),_arb(y)),#(y));for i in z,j in x,k in y:i=p.(j,k)}',line) + call dcl_uproc(parser,'map_const(p:proc,x:any^mshape,y:any)'//& + '{var z=array(p.(_arb(x),y),#x);for i in z,j in x:i=p.(j,y)}',line) + + call dcl_uproc(parser,'+(x:num^any,y:num^any)=map($+,x,y)',line) + call dcl_uproc(parser,'-(x:num^any,y:num^any)=map($-,x,y)',line) + call dcl_uproc(parser,'*(x:num^any,y:num^any)=map($*,x,y)',line) + call dcl_uproc(parser,'/(x:num^any,y:num^any)=map($/,x,y)',line) + call dcl_uproc(parser,'**(x:num^any,y:num^any)=map($**,x,y)',line) + call dcl_uproc(parser,'mod(x:real_num^any,y:real_num^any)=map($mod,x,y)',line) + call dcl_uproc(parser,'max(x:real_num^any,y:real_num^any)=map($max,x,y)',line) + call dcl_uproc(parser,'min(x:real_num^any,y:real_num^any)=map($min,x,y)',line) + call dcl_uproc(parser,'+(x:num^any,y:any)=map_const($+,x,y)',line) + call dcl_uproc(parser,'-(x:num^any,y:any)=map_const($-,x,y)',line) + call dcl_uproc(parser,'*(x:num^any,y:any)=map_const($*,x,y)',line) + call dcl_uproc(parser,'/(x:num^any,y:any)=map_const($/,x,y)',line) + call dcl_uproc(parser,'**(x:num^any,y:any)=map_const($**,x,y)',line) + call dcl_uproc(parser,'mod(x:real_num^any,y:real_num)=map_const($mod,x,y)',line) + call dcl_uproc(parser,'max(x:real_num^any,y:real_num)=map_const($max,x,y)',line) + call dcl_uproc(parser,'min(x:real_num^any,y:real_num)=map_const($min,x,y)',line) + + call dcl_proc(parser,'_pack(v:any,any,any,d:any)->PM__dim v,d',& + "pack",0,line,0) + call dcl_uproc(parser,'pack(v:any^mshape,m:bool^mshape) { '//& + ' test "arrays do not conform"=>conform(#v,#m); '//& + ' result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) }',line) + call dcl_uproc(parser,'pack(vv:array,mm:array) {'//& + ' var v=vv;var m=mm; '//& + ' return _pack(v,m,n,tuple(0..n-1))'//& + ' where n=count(m) }',line) + +write(*,'(a)') '// Reduction' + call dcl_type(parser,'associative_proc is $+,$*,$max,$min,'//& + '$&,$|,$xor,$++,$==,...',line) + + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'reduce(p:proc,x:array(,mshape)) {'//& + 'var s=_get_aelem(x,0);'//& + 'foreach i in 1..size(#x)-1 {'//& + 's=p.(s,_get_aelem(x,i))'//& + '};return s}',line) +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,'reduce(p:proc,x:array(,mshape)) {'//& + 'var y=x;var n=size(x);'//& + 'while n>1 {'//& + ' var m=(n+1)/2;'//& + ' forall k in m..n-1 {'//& + ' PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>)};'//& + ' n=m};return _get_aelem(y,0)}',line) +write(*,'(a)') 'PM__endif' + + call dcl_uproc(parser,'reduce(p:proc,y:array)='//& + '_reduce(p,reduce(p,PM__local(y)))',line) + + call dcl_uproc(parser,'_reduce_for_assign%(p:invar associative_proc,y,init:invar){'//& + 'chan yy=y;return reduce%(p,yy,init)}',line) + call dcl_uproc(parser,'_reduce_for_assign%(p:invar $-,y,init:invar){'//& + 'chan yy=y;return init - _reduce%($+,yy,init)}',line) + call dcl_uproc(parser,'_reduce_for_assign%(p:invar $/,y,init:invar){'//& + 'chan yy=y;return init / _reduce%($*,yy,init)}',line) + + call dcl_uproc(parser,'reduce%(p:invar proc,y:chan,init)='//& + '^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform)',line) + call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& + '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform)',line) + + call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y)',line) + call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y)',line) + + + call dcl_uproc(parser,'_reduce(p:proc,y) {'//& + 'var x=array(y,[0..0]);var z=array(y,[0..0]);'//& + 'var n=this_nnode();var i=1;'//& + 'until i>n-1 {'//& + ' other=_this_node() xor i;'//& + ' if other=y._lo and x<=y._hi',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:int_literal,y:_crange)=(x>=y._lo and x<=y._hi) as ',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi',& + line) + call dcl_uproc(parser,'match_switch_case(x:,y:)=y inc x',line) + call dcl_type(parser,'_crange is rec{_lo,_hi}',line) + call dcl_uproc(parser,'PM__caserange(x,y)=x..y',line) + call dcl_uproc(parser,'PM__caserange(x:fix(int),y:fix(int))='//& + 'new _crange{_lo=x,_hi=y}',line) + +write(*,'(a)') '// Conditional operators' + call dcl_uproc(parser,& + 'PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> '//& + 'same_type(y,z) { var r=z; if x { r=y };return r }',& + line) +!!$ call dcl_uproc(parser,'PM__if(x:bool_literal,y,z)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=> '//& +!!$ 'same_type(y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:int_literal,z:int_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:real_literal,z:real_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:string_literal,z:string_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:bool_literal,z:bool_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:literal,z:literal)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=>''false',line) + +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z)=PM__do_if(x,y,z)',line) + + call dcl_uproc(parser,'PM__if(x:''true,y,z)=y',line) + call dcl_uproc(parser,'PM__if(x:''false,y,z)=z',line) + call dcl_uproc(parser,'PM__if(x:''true,y:literal,z)=y',line) + call dcl_uproc(parser,'PM__if(x:''false,y,z:literal)=z',line) +!!$ call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) + call dcl_uproc(parser,& + 'PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> '//& + 'same_type(y,z) { var r=z; if match(w,x) { r=y };return r }',& + line) + call dcl_uproc(parser,'PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z)',line) + + call dcl_uproc(parser,'PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z)',line) + + call dcl_uproc(parser,'PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...))',line) + +write(*,'(a)') '// Assignment' + call dcl_uproc(parser,& + 'PM__assign_or_init(a,b)<>=a {PM__assign_var(&^(a),b)}',line) + call dcl_uproc(parser,& + 'PM__assign_or_init(a:,b)=PM__dup(b as a)',line) + call dcl_uproc(parser,& + 'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) + call dcl_uproc(parser,& + 'PM__assign(&a:any,b:any) {_assign(&a,c) where c=b as a}',line) + call dcl_type(parser,& + 'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) + call dcl_uproc(parser,& + 'PM__assign(&a:any,b:any,c:assignment_operator) { PM__assign(&a,c.(a,b)) }',line) + call dcl_uproc(parser,& + 'PM__assign(&a:any,b:any,c:proc) { '//& + 'test "Not a recognised assignment operator"=>''false }',line) + call dcl_uproc(parser,'check_assign_types(x,y)'//& + '{test "Type mismatch in assignment"=>same_type(x,y)}',line) + call dcl_uproc(parser,'_assign(&a,b) {_assign_element(&a,b)}',line) + call dcl_uproc(parser,'_assign(&a:contains(farray),b) {_assign_structure(&a,b)}',line) + call dcl_uproc(parser,'_assign_structure(&a,b)<>{_assign_element(&a,b)}',line) + call dcl_uproc(parser,'_assign_structure(&a:farray,b){_array_assign(&a,b,''true)}',line) + call dcl_proc(parser,'_assign_element(&any,any)',"assign",0,line,0) + +write(*,'(a)') '// Other variable operations' + call dcl_proc(parser,'PM__clone(x:any)->=x',"clone",0,line,0) + call dcl_uproc(parser,'PM__dup(PM__dup) <>=PM__clone(PM__dup)',line) + call dcl_proc(parser,'PM__dup(x:fix int)->int',"clone",0,line,0) + call dcl_proc(parser,'PM__dup(x:fix real)->real',"clone",0,line,0) + call dcl_proc(parser,'PM__dup(x:fix string)->string',"clone",0,line,0) + call dcl_proc(parser,'PM__dup(x:fix bool)->bool',"clone",0,line,0) + + call dcl_proc(parser,'PM__getref(x:any)->=x',"get_rf",0,line,0) + call dcl_proc(parser,'same_type(x:any,y:any)->==x,y',& + "logical_return",0,line,proc_needs_type) + call dcl_uproc(parser,'==(x:any,y:any) {'//& + 'test "Cannot apply ""=="" to different types"=> same_type(x,y);'//& + 'var ok=true;_eq(x,y,&ok);return ok}',line) + call dcl_uproc(parser,'/=(x:any,y:any) {'//& + 'test "Cannot apply ""/="" to different types"=> same_type(x,y);'//& + 'var ok=true;_eq(x,y,&ok);return not ok}',line) + call dcl_uproc(parser,& + '_eq(x:any,y:any,&ok) <> { ok=ok and x==y }',line) + call dcl_proc(parser,'PM__copy_out(x:any)->=x',"clone",0,line,0) + call dcl_proc(parser,'PM__copy_back(x:any)->=x',"assign",0,line,0) + + call dcl_uproc(parser,'next_enum(x:int)=x+convert(1,x)',line) + call dcl_uproc(parser,'next_enum(x:int,y:int)=x+convert(y,x)',line) + +write(*,'(a)') '// Type values' + call dcl_proc(parser,'typeof(x:any)->type x',"make_type_val",0,line,proc_needs_type) + call dcl_uproc(parser,'is(x,t)=t inc typeof(x)',line) + call dcl_uproc(parser,'isnt(x,t)=not(x is t)',line) + call dcl_uproc(parser,'as(x,t:)...=PM__cast(x,t)',line) + call dcl_uproc(parser,'as(x,t)=PM__cast(x,typeof(t))',line) + call dcl_proc(parser,'inc(x:,y:)-> inc x,y',"logical_return",0,line,proc_needs_type) + call dcl_uproc(parser,'==(x:,y:)=x inc y and y inc x',line) + call dcl_proc(parser,'error_type()->?0',"0",0,line,proc_needs_type) + +write(*,'(a)') '// Debugging' + call dcl_proc(parser,'_dump(any,any)',"new_dump",0,line,proc_is_impure) + call dcl_uproc(parser,'PM__dump(x)<>:_dump("Value:",x)',line) + call dcl_uproc(parser,'PM__dump(y,x)<>:if y:_dump("Value:",x)',line) + call dcl_uproc(parser,'PM__dump%(x)<>{print("$"++here);_dump(string(here),x)}',line) + call dcl_uproc(parser,'PM__dump%(y:bool,x)<>{if y:_dump(string(here),x)}',line) + call dcl_uproc(parser,'PM__dump%(y,x){'//& + 'test "Selection expression in ''$$dump'' not ''bool''" => ''false;$$infer_type(y)}',line) + + call dcl_proc(parser,'old_dump(any)',"dump",0,line,proc_is_impure) + call dcl_uproc(parser,'old_dumpit(a) { old_dump(a);return a }',line) + call dcl_proc(parser,'old_dump_id(any)',"dump_id",0,line,proc_is_impure) + + contains + + subroutine dcl_proc(iparser,line,opcode,ioparg,iline,iflags) + character(len=*):: line,opcode + character(len=80):: str + str=' ' + if(iand(iflags,proc_is_comm)/=0) str=trim(str)//",is_comm" + if(iand(iflags,proc_is_open)/=0) str=trim(str)//",is_open" + if(iand(iflags,proc_is_each_proc)/=0) str=trim(str)//",is_each_proc" + if(iand(iflags,proc_is_cond)/=0) str=trim(str)//",is_cond" + if(iand(iflags,proc_is_uncond)/=0) str=trim(str)//",is_uncond" + if(iand(iflags,proc_is_abstract)/=0) str=trim(str)//",is_abstract" + if(iand(iflags,proc_is_thru_each )/=0) str=trim(str)//",is_thru_each" + if(iand(iflags,proc_is_empty_each )/=0) str=trim(str)//",is_empty_each" + if(iand(iflags,proc_is_dup_each )/=0) str=trim(str)//",is_dup_each" + if(iand(iflags,proc_is_var )/=0) str=trim(str)//",is_var" + if(iand(iflags,proc_is_generator )/=0) str=trim(str)//",is_generator" + if(iand(iflags,proc_needs_type )/=0) str=trim(str)//",needs_type" + if(iand(iflags,proc_is_recursive )/=0) str=trim(str)//",is_recursive" + if(iand(iflags,proc_is_impure )/=0) str=trim(str)//",is_impure" + if(iand(iflags,proc_is_not_inlinable )/=0) str=trim(str)//",is_not_inlinable" + if(iand(iflags,proc_has_for )/=0) str=trim(str)//",has_for" + if(iand(iflags,proc_is_not_pure_each )/=0) str=trim(str)//",is_not_pure_each" + if(iand(iflags,proc_has_vkeys )/=0) str=trim(str)//",has_vkeys" + if(iand(iflags,proc_is_dcomm )/=0) str=trim(str)//",is_dcomm" + if(iand(iflags,proc_is_file )/=0) str=trim(str)//",is_file" + if(str/=' ') str='<<'//trim(str(2:))//'>>' + if(ioparg<0.or.ioparg>9) stop 'xxx' + write(76,*) adjustl(trim(str)) + write(*,'(a,1h,a,a,a,1h",a,1h",1h(,i1,1h))') 'PM__intrinsic',line,adjustl(trim(str)),': ',opcode,ioparg + end subroutine dcl_proc + + subroutine dcl_type(iparser,line,iline) + character(len=*):: line + write(*,*) + write(*,'(a,a)') 'type ',line + write(*,*) + end subroutine dcl_type + + function aok(line,k) result(ok) + character(len=*):: line + character(len=5):: next + logical:: ok + next=adjustl(line(k+1:)) + ok=.true. + if(next=="where".or.next=="check".or.next(1:4)=="else") ok=.false. + end function aok + + subroutine dcl_uproc(iparser,linez,iline) + character(len=*):: linez + character(len=80),parameter::spaces=' ' + character(len=len(linez)+5):: line + write(*,*) + line="proc "//linez + k=1 + idepth=0 + do i=1,len(line) + select case(line(i:i)) + case(';') + if(i>k) write(*,'(a,a)') spaces(1:idepth),line(k:i-1) + k=i+1 + line(i+1:)=adjustl(line(i+1:)) + case('{') + write(*,'(a,a)') spaces(1:idepth),line(k:i) + k=i+1 + idepth=idepth+2 + line(i+1:)=adjustl(line(i+1:)) + case('}') + idepth=idepth-2 + if(aok(line,i)) then + if(i>k) write(*,'(a,a)') spaces(1:idepth+2),line(k:i-1) + write(*,'(a,a)') spaces(1:idepth),'}' + k=i+1 + line(i+1:)=adjustl(line(i+1:)) + endif + case(' ') + if(i ','sreal ','real ',' ',& - ' ',' ','scpx ','cpx ',& - ' ',' ',' ','bool ',& - ' ',' ',' ',' ',& - ' ',' ',' ',' ',& - 'prc_info ','string ',' ',' ',& - ' ',' ',' ',' ',& - ' ',' ',' '/) + character(len=15),dimension(pm_last_category_type),parameter:: base_types= (/& + 'PM__tinyint ','proc ','type ','name ',& + 'null ','sint ','int ','lint ',& + 'int8 ','int16 ','int32 ','int64 ',& + ' ','sreal ','real ',' ',& + ' ',' ','scpx ','cpx ',& + ' ',' ',' ','bool ',& + ' ',' ',' ',' ',& + ' ',' ',' ',' ',& + 'prc_info ','string ',' ',' ',& + ' ',' ',' ',' ',& + ' ',' ',' ','a_struct ',& + 'a_rec ','a_unique ','a_fix ','a_literal ',& + 'a_basic '/) context%tcache=pm_dict_new(context,128_pm_ln) context%pcache=pm_dict_new(context,1024_pm_ln) @@ -225,7 +245,7 @@ subroutine pm_init_types(context) if(j/=i) call pm_panic('init_type') enddo key(1)=pm_type_is_basic+pm_type_has_storage+pm_type_leaves - do i=pm_null+1,pm_last_sys_type + do i=pm_null+1,pm_last_category_type key(2)=pm_intern(context,trim(base_types(i))) if(pm_debug_level>2) then write(*,*) 'Init types(',trim(base_types(i)),')',key(2) @@ -233,9 +253,27 @@ subroutine pm_init_types(context) j=pm_idict_add(context,context%tcache,key,2,& pm_null_obj) if(j/=i) call pm_panic('init_type') + if(i==pm_last_sys_type) then + key(1)=pm_type_new_category + endif enddo + key(1)=pm_type_new_unfixed + key(2)=0 + key(3)=pm_long + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(3)=pm_single + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(3)=pm_logical + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(3)=pm_string_type + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(1)=pm_type_is_user - do i=1,pm_last_sys_type + do i=1,pm_last_category_type if(base_types(i)(1:1)/='<') then key(2)=pm_intern(context,trim(base_types(i))) j=pm_idict_add(context,context%tcache,key,2,& @@ -640,6 +678,18 @@ function pm_type_num_leaves(context,tno) result(n) n=pm_type_flags(context,tno)/pm_type_leaves end function pm_type_num_leaves + !================================================= + ! Return number of arguments associated with a type + !================================================= + function pm_type_numargs(context,tno) result(n) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: n + n=pm_fast_esize(pm_type_vect(context,tno))-1 + contains + include 'fesize.inc' + end function pm_type_numargs + !================================================= ! Return argument #n of type tno !================================================= @@ -802,10 +852,14 @@ recursive function pm_type_strip_to_basic(context,typ) result(typ2) integer:: typ2 type(pm_ptr):: tv integer:: kind + if(typ==0) then + typ2=0 + return + endif tv=pm_type_vect(context,typ) kind=pm_tv_kind(tv) select case(kind) - case(pm_type_is_all,pm_type_is_vect,pm_type_is_enveloped,& + case(pm_type_is_all,pm_type_is_vect,& pm_type_is_param,& pm_type_is_value,pm_type_is_literal) typ2=pm_type_strip_to_basic(context,pm_tv_arg(tv,1)) @@ -960,35 +1014,17 @@ end function pm_type_replace_mode ! Error codes: ! combined_mode=-1,-2... ! Shared distributed value not allowed for position -combined_mode - ! combined_mode=-1001,-1002,... - ! Partial value not allowed in position -(combined_mode+1000) ! shared_ok -- permissible to have an argumnet with 'shared' mode - ! complete -- cannot have an argument mode associated with a conditional context !============================================================================================ - function pm_type_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& - result(combined_mode) + function pm_type_combine_modes(context,array,shared_ok) result(combined_mode) type(pm_context),pointer:: context integer,intent(in),dimension(:):: array - logical,intent(in):: shared_ok,complete,cond,unlabelled + logical,intent(in):: shared_ok integer:: combined_mode integer:: i,mode,cmode,tno - if(cond) then - combined_mode=sym_partial - return - endif - !cmode=merge(sym_shared,sym_mirrored,shared_ok) cmode=sym_mirrored do i=1,size(array) tno=pm_type_strip_mode(context,array(i),mode) - if(complete) then - if(mode==sym_partial) then - combined_mode=-i-1000 - elseif(mode==sym_coherent& - .and.unlabelled) then - combined_mode=-i-2000 - return - endif - endif if(mode==sym_shared.and..not.shared_ok) then if(iand(pm_type_flags(context,tno),pm_type_has_distributed)/=0) then combined_mode=-i @@ -1414,12 +1450,6 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) return -!!$ case(pm_type_is_vect) -!!$ if(iand(pm_type_flags(context,p),pm_type_has_vect)==0) then -!!$ ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& -!!$ mode,einfo,params,base,user,ubase) -!!$ return -!!$ endif case(pm_type_is_bottom) ok=.true. return @@ -1707,12 +1737,6 @@ recursive function pm_test_type_includes(context,supertype,subtype,& else ok=.false. endif - case(pm_type_is_enveloped) - if(uk==pm_type_is_enveloped) then - ok=pm_tv_name(t)==pm_tv_name(u) - else - ok=.false. - endif case(pm_type_is_except) ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base,user,ubase) @@ -1740,12 +1764,29 @@ recursive function pm_test_type_includes(context,supertype,subtype,& params(nt)=pm_type_combine(context,params(nt),q) endif endif - case(pm_type_is_amp,pm_type_is_vect,pm_type_is_uninitialised) + case(pm_type_is_vect,pm_type_is_uninitialised) ok=tk==uk if(ok) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,einfo,params,base,user,ubase) case(pm_type_is_bottom) ok=.false. + case(pm_type_is_category) + select case(p) + case(pm_a_struct_type) + ok=uk==pm_type_is_struct + case(pm_a_rec_type) + ok=uk==pm_type_is_rec + case(pm_a_unique_type) + ok=uk==pm_type_is_single_name + case(pm_a_literal_type) + ok=uk==pm_type_is_unfixed + case(pm_a_fix_type) + ok=uk==pm_type_is_fix + case(pm_a_basic_type) + ok=uk==pm_type_is_basic + case default + call pm_panic('test-includes,category') + end select case default write(*,*) 'Type=',p write(*,*) 'Kind=',pm_tv_kind(t) @@ -1894,7 +1935,6 @@ recursive function pm_type_contains_elem(context,p,q,& endif endif case(pm_type_is_par_kind,pm_type_is_vect,& - pm_type_is_enveloped,& pm_type_is_contains,pm_type_is_has,& pm_type_is_params,pm_type_is_param) ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& @@ -2140,26 +2180,6 @@ recursive function pm_type_find_elem(context,tno,name,change,& einfo%kind=pm_type_err_elem_not_found offset=0 endif - case(pm_type_is_enveloped) - tno2=pm_tv_arg(tv,2) - tv2=pm_type_vect(context,tno2) - nameset=pm_name_val(context,pm_tv_name(tv2)) - found=.false. - do i=1,pm_fast_esize(nameset) - name2=nameset%data%i(nameset%offset+i) - if(name==abs(name2)) then - found=.true. - exit - endif - enddo - if(.not.found) then - einfo%kind=pm_type_err_elem_not_in_interface - einfo%typ1=tno2 - offset=0 - return - endif - offset=pm_type_find_elem(context,pm_tv_arg(tv,1),& - name,change,stack,top,maxstack,etype,einfo) case default einfo%kind=pm_type_err_elem_bad_type offset=0 @@ -2490,6 +2510,8 @@ subroutine remake(n) end subroutine remake end function pm_type_as_concrete + + !!! Obsolete? recursive function pm_type_remove_params(context,tno,params) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno @@ -2638,7 +2660,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) nv=pm_dict_val(context,context%tcache,int(tno,pm_ln)) narg=pm_tv_numargs(tv) select case(tk) - case(pm_type_is_user,pm_type_is_basic) + case(pm_type_is_user,pm_type_is_basic,pm_type_is_category) name=pm_tv_name(tv) if(name<0) then call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) @@ -2726,7 +2748,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(',')) return enddo - if(amps%data%i(amps%offset+j)==n) then + if(amps%data%i(amps%offset+j)==narg) then if(add_char('&')) return endif call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n) @@ -2847,7 +2869,9 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) call bracket(1,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) case(pm_type_is_value,pm_type_is_literal) if(tk==pm_type_is_value) then - if(add_char('''')) return + if(add_char('fix(')) return + else + if(add_char('literal(')) return endif if(pm_tv_name(tv)==0) then call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) @@ -2866,13 +2890,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) str(n:n)='"' n=n+1 else - str(n:)=pm_number_as_string(context,nv,0_pm_ln) + str(n:)=pm_value_as_string(context,nv) endif n=len_trim(str)+1 - str(n:n)='@' - n=n+1 - str(n:)=pm_int_as_string(pm_tv_name(tv)) - n=len_trim(str)+1 + if(add_char(')')) return endif case(pm_type_is_fix) if(add_char('fix(')) return @@ -2965,9 +2986,6 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) enddo if(add_char('_')) return if(add_char(')')) return - case(pm_type_is_amp) - if(add_char('&')) return - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) case(pm_type_is_vect) if(add_char('^^(')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) diff --git a/src/vm.f90 b/src/vm.f90 index 23ce8a3..6aacb8e 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -36,7 +36,6 @@ module pm_backend use pm_symbol use pm_types use pm_vmdefs - use pm_sysdefs use pm_array use pm_parlib implicit none @@ -1189,20 +1188,18 @@ recursive function pm_run(context,funcin,stackin,pcin,& v=alloc_arg(pm_logical,2) v%data%l(v%offset:v%offset+esize)=opcode2/=0 case(op_get_key) - v=stack%data%ptr(stack%offset+opcode2) - call set_arg(2,v) - w=alloc_arg(pm_logical,3) - if(pm_fast_vkind(v)==pm_tiny_int) then - w%data%l(w%offset:w%offset+esize)=.false. - call set_arg(2,arg(4)) + if(pm_fast_vkind(arg(4))==pm_tiny_int) then + call set_arg(2,arg(1)) else - w%data%l(w%offset:w%offset+esize)=.true. + call set_arg(3,arg(4)) + ve=pm_fast_newnc(context,pm_long,1) + call set_arg(2,make_new_ve(ve,arg(1))) endif - case(op_get_key2) - v=stack%data%ptr(stack%offset+opcode2) - call set_arg(2,v) - case(op_default) - v=alloc_arg(int(opcode2,pm_p),2) + case(op_present) + v=alloc_arg(pm_logical,2) + v%data%l(v%offset:v%offset+esize)=pm_fast_vkind(arg(3))/=pm_tiny_int + case(op_default) + if(.not.ve_is_empty(ve)) call set_arg(2,arg(3)) case(op_miss_arg) arg(2)%data%ptr(arg(2)%offset)=empty_vector case(op_print) @@ -2461,6 +2458,10 @@ recursive function pm_run(context,funcin,stackin,pcin,& endif case(op_add_ln) esize=pm_fast_esize(arg(3)) + if(esize/=pm_fast_esize(arg(4))) then + write(*,*) 'Internal error: import mismatch in op_add_ln' + goto 999 + endif v=alloc_arg(pm_long,2) !if(pm_fast_vkind(arg(3))/=pm_long.or.pm_fast_vkind(arg(4))/=pm_long) goto 999 if(pm_fast_vkind(ve)==pm_logical.and.pm_mask_longadd) then @@ -10462,7 +10463,7 @@ subroutine runtime_error(context,func,pc,ve,noexit,errmesg) call mesg_q_flush() endif if(pm_opts%colour) then - call mesg_q_mess(pm_error_start//'Runtime error: '//pm_error_end//trim(errmesg)) + call mesg_q_mess(pm_opts%error_start//'Runtime error: '//pm_error_end//trim(errmesg)) else call mesg_q_mess('Runtime error: '//trim(errmesg)) endif diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index f90930d..c9ced15 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2020 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -123,7 +123,7 @@ module pm_vmdefs integer,parameter:: op_iota = op_misc2 + 9 integer,parameter:: op_indices = op_misc2 + 10 integer,parameter:: op_get_key = op_misc2 + 11 - integer,parameter:: op_get_key2 = op_misc2 + 12 + integer,parameter:: op_present = op_misc2 + 12 integer,parameter:: op_export_array = op_misc2 + 13 integer,parameter:: op_miss_arg = op_misc2 + 14 integer,parameter:: op_default = op_misc2 + 15 @@ -721,6 +721,9 @@ module pm_vmdefs integer,parameter:: op_or_fold = -26 integer,parameter:: op_except_fold = -27 integer,parameter:: op_concat_fold = -28 + integer,parameter:: op_num_elems_fold = -29 + integer,parameter:: op_type_include_fold = -30 + integer,parameter:: min_op=op_type_include_fold integer,dimension(0:num_op):: op_flags integer,parameter:: op_is_call=1 @@ -826,7 +829,7 @@ module pm_vmdefs data op_flags(op_iota) /0/ data op_flags(op_indices) /0/ data op_flags(op_get_key) /0/ - data op_flags(op_get_key2) /0/ + data op_flags(op_present) /0/ data op_flags(op_export_array) /0/ data op_flags(op_miss_arg) /0/ data op_flags(op_default) /0/ @@ -1049,6 +1052,7 @@ module pm_vmdefs data op_flags(op_i16_offset) /op_is_arith/ data op_flags(op_i32_offset) /op_is_arith/ data op_flags(op_i64_offset) /op_is_arith/ + data op_flags(op_long_offset) /op_is_arith/ data op_flags(op_add_i8) /op_is_arith/ data op_flags(op_sub_i8) /op_is_arith/ @@ -1449,7 +1453,7 @@ module pm_vmdefs subroutine set_op_names integer:: i if(allocated(op_names)) return - allocate(op_names(0:num_op+1)) + allocate(op_names(min_op:num_op+1)) op_names='??' op_names(op_call)='call' op_names(op_comm_call)='comm_call' @@ -1526,7 +1530,7 @@ subroutine set_op_names op_names(op_iota)='iota' op_names(op_indices)='indices' op_names(op_get_key)='get_key' - op_names(op_get_key2)='get_key2' + op_names(op_present)='present' op_names(op_export_array)='export_array' op_names(op_miss_arg)='miss_arg' op_names(op_default)='default' @@ -1578,8 +1582,8 @@ subroutine set_op_names op_names(op_push_node_back)='push_node_back' op_names(op_sys_node)='sys_node' op_names(op_sys_nnode)='sys_nnode' - op_names(op_this_node)='this_node' - op_names(op_this_nnode)='sys_nnode' +!!$ op_names(op_this_node)='this_node' +!!$ op_names(op_this_nnode)='sys_nnode' op_names(op_reduce_ve)='reduce_ve' op_names(op_start_loop_sync)='start_loop_sync' op_names(op_broadcast_val)='broadcast_val' @@ -1749,6 +1753,7 @@ subroutine set_op_names op_names(op_i16_offset)='i16_offset' op_names(op_i32_offset)='i32_offset' op_names(op_i64_offset)='i64_offset' + op_names(op_long_offset)='long_offset' op_names(op_add_i8)='add_i8' op_names(op_sub_i8)='sub_i8' @@ -1885,8 +1890,8 @@ subroutine set_op_names op_names(op_i8_i64)='i8_i64' op_names(op_i16_i64)='i16_i64' op_names(op_i32_i64)='i32_i64' - op_names(op_offset_i8)='offset_i64' - op_names(op_long_i8)='long_i64' + op_names(op_offset_i64)='offset_i64' + op_names(op_long_i64)='long_i64' op_names(op_add_r)='add_r' op_names(op_sub_r)='sub_r' @@ -2064,6 +2069,37 @@ subroutine set_op_names op_names(op_sync)='sync' op_names(op_init_var)='init_var' + op_names(op_add_fold)='add_fold' + op_names(op_sub_fold)='sub_fold' + op_names(op_mult_fold)='mult_fold' + op_names(op_divide_fold)='divide_fold' + op_names(op_div_fold)='div_fold' + op_names(op_mod_fold)='mod_fold' + op_names(op_pow_fold)='pow_fold' + op_names(op_uminus_fold)='uminus_fold' + op_names(op_eq_fold)='eq_fold' + op_names(op_ne_fold)='ne_fold' + op_names(op_gt_fold)='gt_fold' + op_names(op_ge_fold)='ge_fold' + op_names(op_string_fold)='string_fold' + op_names(op_max_fold)='max_fold' + op_names(op_min_fold)='min_fold' + op_names(op_abs_fold)='abs_fold' + op_names(op_band_fold)='band_fold' + op_names(op_bor_fold)='bor_fold' + op_names(op_bxor_fold)='bxor_fold' + op_names(op_bshift_fold)='bshift_fold' + op_names(op_bnot_fold)='bnot_fold' + op_names(op_pdiff_fold)='pdiff_fold' + op_names(op_sign_fold)='sign_fold' + op_names(op_modulo_fold)='modulo_fold' + op_names(op_and_fold)='and_fold' + op_names(op_or_fold)='or_fold' + op_names(op_except_fold)='except_fold' + op_names(op_concat_fold)='concat_fold' + op_names(op_num_elems_fold)='num_elems_fold' + op_names(op_type_include_fold)='type_include_fold' + !!$ do i=op_call,op_comm_loop_par !!$ if(op_names(i)=='??')then !!$ write(*,*) 'MISSING OP NAME>>>>',i,'after',op_names(i-1) diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 1d0cf26..2d55131 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -37,7 +37,6 @@ module pm_wcode use pm_lib use pm_symbol use pm_types - use pm_sysdefs use pm_ast use pm_cnodes use pm_infer @@ -111,7 +110,7 @@ module pm_wcode logical:: proc_shared_inline ! Inlining - type(pm_ptr):: inline_args,outer_rv + type(pm_ptr):: inline_args,inline_keys,inline_key_names,outer_rv logical:: inline_all,inline_none ! Compile time types @@ -179,6 +178,8 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) wcd%typeset=pm_set_new(wcd%context,32_pm_ln) endif wcd%inline_args=pm_null_obj + wcd%inline_keys=pm_null_obj + wcd%inline_key_names=pm_null_obj end subroutine init_wcoder !==================================================== @@ -270,8 +271,7 @@ subroutine wcode_procs(wcd) cnode_args+2,proc_is_not_inlinable) wcd%proc_is_chan=cnode_flags_set(pr,pr_flags,proc_run_complete) wcd%proc_shared_inline=.false. - wcd%npar=cnode_get_num(pr,pr_nret)+& - cnode_get_num(pr,pr_nkeys)+wcd%loop_extra_arg + wcd%npar=cnode_get_num(pr,pr_nret)+wcd%loop_extra_arg if(pm_is_compiling) then if(rv%data%i(rv%offset)==-1) then wcd%retvar=alloc_result_var(wcd,int(pm_null)) @@ -279,15 +279,15 @@ subroutine wcode_procs(wcd) wcd%retvar=alloc_result_var(wcd,rv%data%i(rv%offset)) endif nret=wcd%nvar - if(.not.pm_fast_isnull(keys)) then - p2=pm_fast_newnc(wcd%context,pm_int,& - int(pm_fast_esize(keys)+1)) - wcd%keys=p2 - do j=0,pm_fast_esize(keys) - p2%data%i(p2%offset+j)=& - alloc_key_var(wcd,keys%data%i(keys%offset+j)) - enddo - endif +!!$ if(.not.pm_fast_isnull(keys)) then +!!$ p2=pm_fast_newnc(wcd%context,pm_int,& +!!$ int(pm_fast_esize(keys)+1)) +!!$ wcd%keys=p2 +!!$ do j=0,pm_fast_esize(keys) +!!$ p2%data%i(p2%offset+j)=& +!!$ alloc_key_var(wcd,keys%data%i(keys%offset+j)) +!!$ enddo +!!$ endif if(wcd%loop_extra_arg/=0) then if(vev>0) then wcd%vevar=cvar_alloc_entry(wcd,v_is_parve,0,0,int(pm_logical)) @@ -303,7 +303,8 @@ subroutine wcode_procs(wcd) if(debug_wcode) then write(*,*) 'WCODE PROC> #',i,'SIGNO>',n,'VE>',ve,& 'NRET>',wcd%npar,'NVAR>',wcd%nvar,& - 'CAN INLINE> ',wcd%proc_can_inline,'CHAN>',wcd%proc_is_chan + 'CAN INLINE> ',wcd%proc_can_inline,'CHAN>',wcd%proc_is_chan,& + 'EXTRA>',wcd%loop_extra_arg endif cblock=cnode_get(pr,pr_cblock) call wcode_proc_body(wcd,cblock,rv,ve) @@ -514,6 +515,9 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) npar=wcd%npar p=cnode_get(cblock,cblock_first_var) if(.not.pm_fast_isnull(p)) then +!!$ write(*,*) 'ALLOCATING PARAM maybe>',& +!!$ trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))),& +!!$ cnode_flags_set(p,var_flags,var_is_param) do while(cnode_flags_set(p,var_flags,var_is_param)) slot=cnode_get_num(p,var_index) typ=get_var_type(wcd,p,rv) @@ -791,7 +795,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) logical:: break type(pm_ptr):: args - integer:: nargs,totargs,nret + integer:: nargs,totargs,nkeys,nret integer:: costart,cs,save_xbase,save_top,save_lbtop integer(pm_p):: m integer:: i,j,k,opr,tk,name,name2,new_ve,new_ve2,sig @@ -799,12 +803,12 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) type(pm_ptr):: arg,u,v,tv logical:: varg,ok,break2,save_inline_none integer:: typ,pc,jmp,tno,idx,n,ii,kk,slot,slot1,slot2,slot3 - + if(pm_debug_checks) then if(cnode_get_kind(callnode)/=cnode_is_call) & call pm_panic('Wcode call') endif - + break=.false. args=cnode_get(callnode,call_args) @@ -812,7 +816,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) nret=cnode_get_num(callnode,call_nret) sig=-cnode_get_num(callnode,call_sig) new_ve=-1 - + if(debug_wcode) then if(sig>0) then write(*,*) 'WCODE CALL>',sym_names(sig) @@ -882,9 +886,9 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif k=wcd%pc if(wcode_cblock(wcd,arg,rv,new_ve2).neqv.break2) then - call wcode_error(wcd,callnode,& - 'Communicating operations do not match '//& - 'in different branches of "if"/"switch"') + call wcode_error(wcd,callnode,& + 'Communicating operations do not match '//& + 'in different branches of "if"/"switch"') endif if(.not.break2) call release_var(wcd,new_ve2) if(break2) then @@ -905,7 +909,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) new_ve=0 if(tno==wcd%true_name) then call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%lstack(wcd%ltop-1),rv,new_ve) elseif(tno==wcd%false_name) then if(.not.pm_fast_isnull(cnode_arg(args,3))) then call wcode_comm_block(wcd,cnode_arg(args,3),& @@ -920,7 +924,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) if(.not.pm_fast_isnull(cnode_arg(args,3))) then call comp_start_else_block(wcd,pc) call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%lstack(wcd%ltop-1),rv,new_ve) call comp_finish_else_block(wcd,pc) else call comp_finish_block(wcd,pc) @@ -1144,7 +1148,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) break2=wcode_cblock(wcd,cnode_arg(args,8),rv,new_ve) call comp_start_else_block(wcd,pc) call arg_set_slot(wcd,cnode_arg(args,2),& - arg_slot(wcd,cnode_arg(args,4))) + arg_slot(wcd,cnode_arg(args,4))) if(sig==sym_pm_serve.or.sig==sym_pm_recv) then call arg_set_slot(wcd,cnode_arg(args,6),& arg_slot(wcd,cnode_arg(args,3))) @@ -1421,72 +1425,98 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) endif case(sym_present) - v=cnode_arg(cnode_arg(args,3),1) - idx=v%data%i(v%offset) - v=cnode_arg(cnode_arg(args,4),1) - idx=idx+v%data%i(v%offset) if(wcd%base==0) then - if(pm_is_compiling) then - v=cnode_arg(cnode_arg(args,4),1) - idx=v%data%i(v%offset) - i=wcd%keys%data%i(wcd%keys%offset+idx-1) - call wc_call(wcd,callnode,op_if,0,4,0,ve) - pc=comp_start_if_else_block(wcd) - call wc(wcd,cvar_ptr(wcd,i,1)) - call comp_assign_slots(wcd,callnode,arg_slot(wcd,cnode_arg(args,1)),& - cvar_ptr(wcd,i,2),.true.,rv,ve) - call comp_start_else_block(wcd,pc) - call comp_assign(wcd,callnode,cnode_arg(args,1),cnode_arg(args,5),.true.,rv,ve) - call comp_finish_else_block(wcd,pc) - else - call wc_call(wcd,callnode,op_get_key,idx+& - wcd%loop_extra_arg+pm_stack_locals,4,2,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,2),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,5),.false.,rv,ve) - endif + call wc_call_args(wcd,callnode,args,op_present,0,2,1,rv,ve) else - arg=cnode_arg(wcd%inline_args,idx+wcd%keybase-1) - ok=.true. - if(cnode_get_kind(arg)==cnode_is_const) then - if(pm_fast_vkind(cnode_arg(arg,1))==pm_tiny_int) then - ok=.false. - endif - endif - call release_var(wcd,var_slot(wcd,cnode_arg(args,1))) - if(ok) then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - arg,wcd%oldbase,rv,ve) - call wc_call(wcd,callnode,op_logical_return,1,2,1,ve) - call wc_arg(wcd,cnode_arg(args,2),.true.,rv,ve) + ! Inline version + if(.not.pm_fast_isnull(wcd%inline_keys)) then + ok=.false. + do j=1,cnode_numargs(wcd%inline_keys) + if(wcd%inline_key_names%data%i(wcd%inline_key_names%offset+j-1)==& + cnode_get_num(cnode_arg(args,i),var_name)) then + ok=.true. + endif + enddo else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,5),wcd%base,rv,ve) - call wc_call(wcd,callnode,op_logical_return,0,2,1,ve) - call wc_arg(wcd,cnode_arg(args,2),.true.,rv,ve) + ok=.false. endif + call wc_call(wcd,callnode,op_logical_return,merge(1,0,ok),2,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) endif case(sym_key) - v=cnode_arg(cnode_arg(args,2),1) - idx=v%data%i(v%offset) + n=nargs/4 if(wcd%base==0) then - if(pm_is_compiling) then - wcd%rdata(cnode_get_num(cnode_arg(args,1),var_index)+wcd%base)=& - -wcd%keys%data%i(wcd%keys%offset+idx-1) - else - v=cnode_arg(cnode_arg(args,3),1) - idx=idx+v%data%i(v%offset)+wcd%loop_extra_arg - call wc_call_args(wcd,callnode,args,op_get_key2,& - idx+pm_stack_locals,1,1,rv,ve) - endif + do i=1,nargs/4 + if(get_arg_type(wcd,cnode_arg(args,i+n),rv)==& + get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv).or..true.) then + if(pm_is_compiling) then + call wc_call(wcd,callnode,op_get_key,0,5,1,ve) + pc=comp_start_block(wcd) + break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,ve) + call comp_finish_block(wcd,pc) + call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) + call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,ve) + else + new_ve=alloc_var(wcd,pm_ve_type) + call wc_call(wcd,callnode,op_get_key,0,4,0,ve) + call wc(wcd,-new_ve) + call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) + call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) + break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) + call wc_call(wcd,callnode,op_default,0,3,1,new_ve) + call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,new_ve) + call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,new_ve) + endif + else + write(*,*) 'Diffnt',& + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i+n),rv))),& + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv))) + ! key arg type differs from default value - so key arg must be present + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(args,i),wcd%base,rv,ve) + endif + enddo else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(wcd%inline_args,idx+wcd%keybase),wcd%oldbase,& - rv,ve) - endif - case(sym_default) - call wc_call_args(wcd,callnode,args,op_default,& - check_arg_type(wcd,args,rv,1),1,1,rv,ve) + ! Inline case + outer:do i=1,n + if(.not.pm_fast_isnull(wcd%inline_keys)) then + do j=1,cnode_numargs(wcd%inline_keys) + v=cnode_arg(wcd%inline_keys,j) + if(wcd%inline_key_names%data%i(wcd%inline_key_names%offset+j-1)==& + cnode_get_num(cnode_arg(args,i),var_name)) then + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(wcd%inline_keys,j),wcd%oldbase,rv,ve) + cycle outer + endif + enddo + endif + break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(args,i*2+n+n),wcd%base,rv,ve) + enddo outer + endif + +!!$ v=cnode_arg(cnode_arg(args,2),1) +!!$ idx=v%data%i(v%offset) +!!$ if(wcd%base==0) then +!!$ if(pm_is_compiling) then +!!$ wcd%rdata(cnode_get_num(cnode_arg(args,1),var_index)+wcd%base)=& +!!$ -wcd%keys%data%i(wcd%keys%offset+idx-1) +!!$ else +!!$ v=cnode_arg(cnode_arg(args,3),1) +!!$ idx=idx+v%data%i(v%offset)+wcd%loop_extra_arg +!!$ call wc_call_args(wcd,callnode,args,op_get_key2,& +!!$ idx+pm_stack_locals,1,1,rv,ve) +!!$ endif +!!$ else +!!$ call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& +!!$ cnode_arg(wcd%inline_args,idx+wcd%keybase),wcd%oldbase,& +!!$ rv,ve) +!!$ endif +!!$ case(sym_default) +!!$ call wc_call_args(wcd,callnode,args,op_default,& +!!$ check_arg_type(wcd,args,rv,1),1,1,rv,ve) case(sym_init_var) call wc_call(wcd,callnode,op_init_var,0,2,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) @@ -1567,7 +1597,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call_args(wcd,callnode,args,op_import_val,0,nargs,1,rv,new_ve) else call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) + cnode_arg(args,2),wcd%base,rv,ve) endif case(sym_import_varg) if(.not.pm_is_compiling) then @@ -1575,7 +1605,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) n=wcd%top-wcd%xbase if(wcd%top+n>max_code_stack) call pm_panic('out of code stack') do i=1,n - !!! Note this is not right type (for vm only does not matter) +!!! Note this is not right type (for vm only does not matter) wcd%rdata(wcd%top+i)=alloc_var(wcd,pm_ve_type) enddo do i=1,n @@ -1665,7 +1695,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) trim(pm_type_as_string(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))) endif - + call comp_assign_slots(wcd,callnode,& arg_slot_in_frame(wcd,cnode_arg(wcd%inline_args,n),wcd%oldbase),& slot,.true.,rv,ve) @@ -1702,15 +1732,20 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) else totargs=nargs endif + if(pm_fast_isnull(cnode_get(callnode,call_keys))) then + nkeys=0 + else + nkeys=cnode_numargs(cnode_get(callnode,call_keys)) + endif if(cnode_flags_clear(callnode,call_flags,call_is_comm)) then call wcode_proc_call(wcd,callnode,rv,ve,-1,& - args,nargs,totargs,nret,sig) + args,nargs,totargs,nkeys,nret,sig) !!$ elseif(pm_is_compiling) then !!$ break=.true. !!$ return else call wcode_proc_call(wcd,callnode,rv,wcd%lstack(wcd%ltop-1),ve,& - args,nargs,totargs,nret,sig) + args,nargs,totargs,nkeys,nret,sig) endif end select if(debug_wcode) then @@ -1756,8 +1791,8 @@ subroutine for_statement v=cnode_arg(u,2) rv%data%i(rv%offset+slot:rv%offset+slot2)=& v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - call comp_start_else_block(wcd,pc) + if(pm_is_compiling) then + call comp_start_else_block(wcd,pc) if(wcd%num_errors==0) call for_body(0) call comp_finish_else_block(wcd,pc) else @@ -1768,7 +1803,7 @@ subroutine for_statement endif endif end subroutine for_statement - + subroutine for_body(ve) integer:: j,ve integer:: save_xbase,save_top @@ -1813,7 +1848,7 @@ subroutine any_statement slot=v%data%i(v%offset) slot2=v%data%i(v%offset+1_pm_p) u=pm_dict_val(wcd%context,wcd%sig_cache,int(& - rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) + rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) if(.not.pm_is_compiling) new_ve=alloc_var(wcd,pm_ve_type) any_break=.false. do kk=1,cnode_numargs(u) @@ -1844,7 +1879,7 @@ subroutine any_statement enddo call release_var(wcd,new_ve) end subroutine any_statement - + subroutine each_proc_body integer:: i,j,typ,slot,slot2,slot3 integer:: n,ii @@ -1938,7 +1973,7 @@ subroutine each_proc_body break=wcode_cblock(wcd,cnode_arg(args,nret+1),rv,ve) endif end subroutine each_proc_body - + function rvv(n) result(m) integer,intent(in):: n integer:: m @@ -1952,7 +1987,7 @@ subroutine release_import_varg(xbase) call release_var(wcd,wcd%rdata(i)) enddo end subroutine release_import_varg - + end function wcode_call !======================================== @@ -1974,20 +2009,20 @@ end function call_flag_set ! ve2 = vector engine for inner scope !==================================================================== recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& - args,nargs,totargs,nret,sig) + args,nargs,totargs,nkeys,nret,sig) type(wcoder),intent(inout):: wcd type(pm_ptr),intent(in):: callnode,rv integer,intent(in):: ve,ve2 type(pm_ptr),intent(in):: args - integer,intent(in):: nargs,totargs,nret + integer,intent(in):: nargs,totargs,nkeys,nret integer,intent(in):: sig integer:: ve1,idx,procnode_kind,op,slot,slot2,slot3,typ - integer:: i,j,arg_base,nkeys,op2,taints,par_kind,pc - type(pm_ptr):: procnode,arg,tv,amps + integer:: i,j,arg_base,op2,taints,par_kind,pc,tno,nproc_keys + type(pm_ptr):: keys,key_names,proc_keys,procnode,arg,tv,amps,p logical:: varg,ok,autocv,save_inline_all,steps_back,enclosing_block integer:: extra_ve,ignore_args logical:: keep_ctime_const - integer,dimension(totargs):: conv + integer,dimension(-nkeys:totargs):: conv if(ve2<0) then extra_ve=0 else @@ -2038,11 +2073,15 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& par_kind=0 ! Get signature details + + !write(*,*) 'GETSIG>',idx + procnode=pm_dict_key(wcd%context,wcd%sig_cache,int(idx,pm_ln)) if(pm_fast_esize(procnode)>1) par_kind=procnode%data%i(procnode%offset+2) procnode=pm_dict_val(wcd%context,wcd%sig_cache,int(idx,pm_ln)) varg=cnode_flags_set(callnode,call_flags,call_is_vararg) procnode_kind=cnode_get_kind(procnode) + keys=cnode_get(callnode,call_keys) ! Process any autoconversions conv=-1 @@ -2084,11 +2123,14 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif wcd%inline_all=save_inline_all keep_ctime_const=.false. + key_names=pm_name_val(wcd%context,cnode_get_num(callnode,call_key_names)) + proc_keys=cnode_get(cnode_arg(procnode,1),pr_keys) + nproc_keys=pm_fast_esize(proc_keys)/2 else ! Intrinsic procedure - operator info stored in proc object op=cnode_get_num(procnode,bi_opcode) op2=cnode_get_num(procnode,bi_opcode2) - if(cnode_flags_set(procnode,bi_flags,proc_needs_type)) then + if(cnode_flags_set(procnode,pr_flags,proc_needs_type)) then if(op==op_logical_return) then if(check_arg_type(wcd,args,rv,1)==wcd%false_name) then op2=0 @@ -2096,7 +2138,11 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& op2=1 endif elseif(op==op_elem) then - call pm_panic('op_elem in proc_needs_type') + if(nargs==3) then + tno=check_arg_type(wcd,args,rv,3) + p=pm_type_val(wcd%context,tno) + op2=p%data%ln(p%offset)+1 + endif else op2=check_arg_type(wcd,args,rv,1) endif @@ -2112,6 +2158,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& extra_ve=0 endif keep_ctime_const=.true. + nproc_keys=0 endif !write(*,*) 'CALLVE> PRE',ve1 @@ -2125,7 +2172,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& ! Start coding the call instruction !write(*,*) 'CALLVE>',ve1 - call wc_call(wcd,callnode,op,op2,totargs+extra_ve+1-ignore_args,nret,ve1) + call wc_call(wcd,callnode,op,op2,& + totargs+extra_ve+1-ignore_args+merge(nkeys,nproc_keys,pm_is_compiling),nret,ve1) if(extra_ve>0) then call wc(wcd,ve2) endif @@ -2135,16 +2183,6 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& call wc_p_arg(wcd,cnode_arg(args,i),.true.,rv,ve1,.false.) enddo - ! Keyword arguments treated slighly differenly when compiling - if(pm_is_compiling) then - nkeys=cnode_get_num(callnode,call_nkeys) - if(nkeys>0) then - call comp_keys(nkeys) - endif - else - nkeys=0 - endif - ! If compiling need to flag up any "&" args ! (mainly for optimiser) if(pm_is_compiling) then @@ -2157,7 +2195,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& ! Code arguments before arg... arg_base=wcd%pc j=0 - do i=nret+nkeys+1+ignore_args,nargs + do i=nret+1+ignore_args,nargs if(pm_is_compiling.and..not.pm_fast_isnull(amps)) then if(amps%data%i(amps%offset+j)+nret+nkeys==i) then call wc_p_arg(wcd,cnode_arg(args,i),.true.,rv,ve1,keep_ctime_const) @@ -2185,6 +2223,34 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif enddo + ! Code keyword arguments + if(pm_is_compiling) then + ! ... TODO ... + else + if(pm_fast_isnull(keys)) then + do j=1,nproc_keys + call wc(wcd,& + -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) + enddo + else + outer: do j=1,nproc_keys + do i=1,nkeys + if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then + if(conv(-i)>0) then + call wc_p(wcd,conv(-i),keep_ctime_const) + call release_var(wcd,conv(-i)) + else + call wc_p_arg(wcd,cnode_arg(keys,i),.false.,rv,ve1,keep_ctime_const) + endif + cycle outer + endif + enddo + call wc(wcd,& + -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) + enddo outer + endif + endif + ! When compiling some args may have been disagregated ! so neeed to correct number of arguments if(pm_is_compiling) then @@ -2218,15 +2284,22 @@ subroutine autoconv arg=cnode_arg(procnode,i) ! Argument indices are coded as displacements back from end of args ! (gets around possible presence of keyword args) - idx=totargs-arg%data%i(arg%offset) + idx=arg%data%i(arg%offset) if(pm_fast_esize(arg)==1) then tno=arg%data%i(arg%offset+1) slot=alloc_var(wcd,tno) call wc_call(wcd,callnode,op_make_poly,tno,3,1,ve) call wc(wcd,-slot) - call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) + if(idx<0) then + call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) + else + call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) + endif else - if(idx<=nargs) then + if(idx<0) then + slot=get_sub_elem(wcd,callnode,op_elem,cnode_arg(keys,-idx),& + arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) + elseif(idx<=nargs) then slot=get_sub_elem(wcd,callnode,op_elem,cnode_arg(args,idx),& arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) else @@ -2302,12 +2375,8 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) enddo endif - ! Cannot currently inline procs with keyword args +!!$ ! Cannot currently inline procs with keyword args p=cnode_arg(proc,1) - if(cnode_get_num(p,pr_nkeys)>0) then - ok=.false. - return - endif ! For now cannot inline shared calls flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proc_run_shared+proc_run_local) @@ -2315,17 +2384,6 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) ok=.false. return endif - -!!$ ! .. or calls returning shared/uniform when compiling -!!$ if(pm_is_compiling.and..false.) then -!!$ if(nret>0.and.extra_ve==0) then -!!$ tno=check_arg_type_with_mode(wcd,args,rv,1) -!!$ if(pm_type_get_mode(wcd%context,tno)>=sym_mirrored) then -!!$ ok=.false. -!!$ return -!!$ endif -!!$ endif -!!$ endif ! Always inline "each" procs if(cnode_flags_set(p,pr_flags,proc_is_each_proc)) then @@ -2338,6 +2396,7 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) ok=.false. return endif + if(wcd%inline_all) then ok=.true. return @@ -2487,8 +2546,9 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre integer:: save_base,save_oldbase,save_xbase,save_lbase,save_keybase,save_lbl integer:: save_loop_extra_arg + type(pm_ptr):: save_args,save_rv,save_keys,save_key_names logical:: save_proc_is_chan,save_shared_inline - type(pm_ptr):: pr,p,c,cblock,rv,save_args,save_rv,arg,tv + type(pm_ptr):: pr,p,c,cblock,rv,arg,tv integer:: pc,depth,par,num_named,first_pc,npar,slot,i,n,xarg,tno,lastxarg logical:: break integer:: ve @@ -2519,6 +2579,8 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre save_lbase=wcd%lbase save_xbase=wcd%xbase save_args=wcd%inline_args + save_keys=wcd%inline_keys + save_key_names=wcd%inline_key_names save_rv=wcd%outer_rv save_keybase=wcd%keybase save_proc_is_chan=wcd%proc_is_chan @@ -2526,6 +2588,8 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre save_shared_inline=wcd%proc_shared_inline wcd%inline_args=args + wcd%inline_keys=cnode_get(callnode,call_keys) + wcd%inline_key_names=pm_name_val(wcd%context,cnode_get_num(callnode,call_key_names)) if(debug_wcode) then write(*,*) 'INLINE PAR TYPES>>' @@ -2547,8 +2611,8 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre if(debug_wcode) write(*,*) 'Inline>',pm_name_as_string(wcd%context,cnode_get_num(pr,pr_name)) cblock=cnode_get(pr,pr_cblock) rv=cnode_arg(proc,2) - nkeys=cnode_get_num(pr,pr_nkeys) - npar=nret+1+nkeys + !nkeys=cnode_get_num(pr,pr_nkeys) + npar=nret+1 wcd%keybase=nret wcd%proc_is_chan=cnode_flags_set(pr,pr_flags,proc_run_complete) @@ -2673,6 +2737,8 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre wcd%oldbase=save_oldbase wcd%outer_rv=save_rv wcd%inline_args=save_args + wcd%inline_keys=save_keys + wcd%inline_key_names=save_key_names wcd%keybase=save_keybase wcd%vevar=save_vevar wcd%proc_is_chan=save_proc_is_chan @@ -3653,10 +3719,10 @@ subroutine wc_call(wcd,node,op,op2,nargs,nret,ve) call pm_panic('wc call not callnode') endif endif - depth=cnode_get_num(node,call_par_depth) - if(depth/=0) depth=depth+wcd%lbase + depth=cnode_get_num(node,call_par_depth)+wcd%lbase + !if(depth/=0) depth=depth+wcd%lbase if(depthmax_wcode_errors) then From bc579fa8dbc4623c03fd9d5cbcfda7b74bdccc93 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 19 Jul 2024 15:12:00 +0100 Subject: [PATCH 09/36] Refactor keyword argumentswq --- config/sysdep.f90 | 31 +++++++++++++++++++------------ pm/Makefile | 17 +++++++---------- 2 files changed, 26 insertions(+), 22 deletions(-) diff --git a/config/sysdep.f90 b/config/sysdep.f90 index 65df6ba..0a8d983 100644 --- a/config/sysdep.f90 +++ b/config/sysdep.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2019 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -35,11 +35,14 @@ module pm_sysdep ! ********* Error messages **************** ! Error messages in colour logical:: pm_colour_messages=.true. + logical:: pm_bright_messages=.true. + logical:: pm_bold_messages=.true. + character(len=*),parameter:: pm_error_start_bright=achar(27)//'[91;1m' character(len=*),parameter:: pm_error_start=achar(27)//'[31;1m' character(len=*),parameter:: pm_error_end=achar(27)//'[39;22m' character(len=*),parameter:: pm_loc_start=achar(27)//'[1m' character(len=*),parameter:: pm_loc_end=achar(27)//'[22m' - + ! ********* File settings ***************** ! Standard output integer,parameter:: pm_stdout_unit=6 @@ -50,8 +53,8 @@ module pm_sysdep ! Suffix for input files character(len=4),parameter:: pm_file_suffix='.pmm' - ! Prefix for library files - character(len=15),parameter:: pm_file_prefix='/usr/lib/pm/lib' + ! Environment variable holding location of library files + character(len=15),parameter:: pm_env_var='PMMLIB' ! Directory separator (one character only) character(len=1),parameter:: pm_file_dirsep='/' @@ -83,13 +86,13 @@ module pm_sysdep ! Types used by memory model (block offsets,object sizes,bitmap flags) ! integer,parameter:: pm_p=kind(1) ! Pointer offsets, object types + - ! flags (>~24 bits, typically int) + ! flags (>~24 bits, typically int) -integer,parameter:: pm_p=8 + integer,parameter:: pm_p=8 - integer,parameter:: pm_f=kind(1) ! Bitmap storage (integer word) - ! On some systems int64 may - ! improve things slightly + integer,parameter:: pm_f=kind(1) ! Bitmap storage (integer word) + ! On some systems int64 may + ! improve things slightly ! ********* Vector Virtual Machine ******** @@ -204,15 +207,19 @@ end function pm_isatty subroutine pm_module_filename(inbuffer,buffer) character(len=*):: inbuffer,buffer integer:: n,m + character(len=pm_max_filename_size):: libpath buffer=inbuffer n=len_trim(buffer) if(n>len(pm_file_suffix)) then if(buffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) return endif if(buffer(1:4)=='lib.') then - m=len(pm_file_prefix) - buffer(m+1:m+n)=buffer(1:n) - buffer(1:m)=pm_file_prefix + call get_environment_variable(pm_env_var,libpath) + m=len_trim(libpath) + if(m>0) then + buffer(m+1:m+n)=buffer(1:n) + buffer(1:m)=libpath + endif endif do m=1,n if(buffer(m:m)=='.') then diff --git a/pm/Makefile b/pm/Makefile index 2f05c4b..87c9bbd 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -27,7 +27,7 @@ PC=mpifort FFLAGS= -g -I../src -fbounds-check -fcheck=mem # -Wall PFLAGS= -g -I../src -fbounds-check -fcheck=mem -PMCODE= sysdep.o kinds.o pcomp.o memory.o hash.o opts.o lib.o symbol.o types.o ast.o parser.o linker.o vmdefs.o sysdefs.o cnodes.o codegen.o infer.o wcoder.o array.o parlib.o vm.o main.o +PMCODE= sysdep.o kinds.o pcomp.o memory.o hash.o opts.o lib.o symbol.o types.o ast.o parser.o linker.o vmdefs.o cnodes.o codegen.o infer.o wcoder.o array.o parlib.o vm.o main.o PMCODE2= ../config/sysdep.f90 ../src/kinds.f90 ../src/pcomp.f90 ../src/memory.f90 ../src/hash.f90 ../src/opts.f90 ../src/lib.f90 ../src/symbol.f90 ../src/types.f90 ../src/ast.f90 ../src/parser.f90 ../src/linker.f90 ../src/vmdefs.f90 ../src/sysdefs.f90 ../src/cnodes.f90 ../src/codegen.f90 ../src/infer.f90 ../src/wcoder.f90 ../src/array.f90 ../src/parlib.f90 ../src/vm.f90 ../src/main.f90 @@ -86,25 +86,22 @@ parlib.o : ../src/parlib.f90 array.o types.o symbol.o lib.o opts.o hash.o memory linker.o : ../src/linker.f90 ast.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -sysdefs.o : ../src/sysdefs.f90 vmdefs.o ast.o parser.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +cnodes.o : ../src/cnodes.f90 ast.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -cnodes.o : ../src/cnodes.f90 ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +wcoder.o : ../src/wcoder.f90 array.o infer.o cnodes.o ast.o symbol.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -wcoder.o : ../src/wcoder.f90 array.o infer.o cnodes.o ast.o symbol.o sysdefs.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +vm.o : ../src/vm.f90 parlib.o array.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -vm.o : ../src/vm.f90 parlib.o array.o sysdefs.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o - $(FC) $(FFLAGS) -c $< - -main.o : ../src/main.f90 vm.o parlib.o array.o wcoder.o infer.o codegen.o linker.o parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +main.o : ../src/main.f90 vm.o parlib.o array.o wcoder.o infer.o codegen.o linker.o parser.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(PFLAGS) -c $< From 72c144da6796afdfb46ec41484afe5f48cba02f5 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Tue, 10 Sep 2024 17:18:47 +0100 Subject: [PATCH 10/36] Closures and dot procs --- pm/Makefile | 2 +- pm/lib/sys/pm.pmm | 474 +++++++++------- src/ast.f90 | 66 +-- src/cnodes.f90 | 86 ++- src/codegen.f90 | 1090 ++++++++++++++++++++++++------------ src/infer.f90 | 823 +++++++++++++-------------- src/lib.f90 | 10 +- src/parser.f90 | 1342 +++++++++++++++++++++------------------------ src/symbol.f90 | 238 ++++---- src/types.f90 | 228 ++++---- src/vmdefs.f90 | 18 +- src/wcoder.f90 | 175 ++---- 12 files changed, 2430 insertions(+), 2122 deletions(-) diff --git a/pm/Makefile b/pm/Makefile index 87c9bbd..4d85d10 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -83,7 +83,7 @@ array.o : ../src/array.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o parlib.o : ../src/parlib.f90 array.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(PC) $(PFLAGS) -c $< -linker.o : ../src/linker.f90 ast.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +linker.o : ../src/linker.f90 parser.o ast.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< cnodes.o : ../src/cnodes.f90 ast.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm index 2ec47d1..9967ddd 100644 --- a/pm/lib/sys/pm.pmm +++ b/pm/lib/sys/pm.pmm @@ -53,7 +53,7 @@ PM__intrinsic abs(literal(int))->(literal(int)) : "abs_fold" PM__intrinsic ~(literal(int))->(literal(int)) : "bnot_fold" PM__intrinsic &(literal(int),literal(int))->(literal(int)) : "band_fold" PM__intrinsic |(literal(int),literal(int))->(literal(int)) : "bor_fold" -PM__intrinsic xor(literal(int),literal(int))->(literal(int)) : "bxor_fold" +PM__intrinsic ~(literal(int),literal(int))->(literal(int)) : "bxor_fold" PM__intrinsic shift(literal(int),literal(int))->(literal(int)) : "bshift_fold" PM__intrinsic pdiff(literal(int),literal(int))->(literal(int)) : "pdiff_fold" PM__intrinsic sign(literal(int),literal(int))->(literal(int)) : "sign_fold" @@ -86,7 +86,7 @@ PM__intrinsic abs(fix(int))->(fix(int)) : "abs_fold" PM__intrinsic ~(fix(int))->(fix(int)) : "bnot_fold" PM__intrinsic &(fix(int),fix(int))->(fix(int)) : "band_fold" PM__intrinsic |(fix(int),fix(int))->(fix(int)) : "bor_fold" -PM__intrinsic xor(fix(int),fix(int))->(fix(int)) : "bxor_fold" +PM__intrinsic ~(fix(int),fix(int))->(fix(int)) : "bxor_fold" PM__intrinsic shift(fix(int),fix(int))->(fix(int)) : "bshift_fold" PM__intrinsic pdiff(fix(int),fix(int))->(fix(int)) : "pdiff_fold" PM__intrinsic sign(fix(int),fix(int))->(fix(int)) : "sign_fold" @@ -151,7 +151,7 @@ PM__intrinsic abs(sint)->(sint) : "abs_i" PM__intrinsic bit_not(sint)->(sint) : "bnot_i" PM__intrinsic &(sint,sint)->(sint) : "band_i" PM__intrinsic |(sint,sint)->(sint) : "bor_i" -PM__intrinsic xor(sint,sint)->(sint) : "bxor_i" +PM__intrinsic ~(sint,sint)->(sint) : "bxor_i" PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" PM__intrinsic sign(sint,sint)->(sint) : "sign_i" @@ -188,7 +188,7 @@ PM__intrinsic abs(int)->(int) : "abs_ln" PM__intrinsic ~(int)->(int) : "bnot_ln" PM__intrinsic &(int,int)->(int) : "band_ln" PM__intrinsic |(int,int)->(int) : "bor_ln" -PM__intrinsic xor(int,int)->(int) : "bxor_ln" +PM__intrinsic ~(int,int)->(int) : "bxor_ln" PM__intrinsic shift(int,int)->(int) : "bshift_ln" PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" PM__intrinsic sign(int,int)->(int) : "sign_ln" @@ -232,7 +232,7 @@ PM__intrinsic abs(lint)->(lint) : "abs_offset" PM__intrinsic ~(lint)->(lint) : "bnot_offset" PM__intrinsic &(lint,lint)->(lint) : "band_offset" PM__intrinsic |(lint,lint)->(lint) : "bor_offset" -PM__intrinsic xor(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic ~(lint,lint)->(lint) : "bxor_offset" PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" @@ -275,7 +275,7 @@ PM__intrinsic abs(int8)->(int8) : "abs_i8" PM__intrinsic ~(int8)->(int8) : "bnot_i8" PM__intrinsic &(int8,int8)->(int8) : "band_i8" PM__intrinsic |(int8,int8)->(int8) : "bor_i8" -PM__intrinsic xor(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic ~(int8,int8)->(int8) : "bxor_i8" PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" @@ -318,7 +318,7 @@ PM__intrinsic abs(int16)->(int16) : "abs_i16" PM__intrinsic ~(int16)->(int16) : "bnot_i16" PM__intrinsic &(int16,int16)->(int16) : "band_i16" PM__intrinsic |(int16,int16)->(int16) : "bor_i16" -PM__intrinsic xor(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic ~(int16,int16)->(int16) : "bxor_i16" PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" @@ -361,7 +361,7 @@ PM__intrinsic abs(int32)->(int32) : "abs_i32" PM__intrinsic ~(int32)->(int32) : "bnot_i32" PM__intrinsic &(int32,int32)->(int32) : "band_i32" PM__intrinsic |(int32,int32)->(int32) : "bor_i32" -PM__intrinsic xor(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic ~(int32,int32)->(int32) : "bxor_i32" PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" @@ -405,7 +405,7 @@ PM__intrinsic abs(int64)->(int64) : "abs_i64" PM__intrinsic ~(int64)->(int64) : "bnot_i64" PM__intrinsic &(int64,int64)->(int64) : "band_i64" PM__intrinsic |(int64,int64)->(int64) : "bor_i64" -PM__intrinsic xor(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic ~(int64,int64)->(int64) : "bxor_i64" PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" @@ -568,11 +568,13 @@ PM__intrinsic im(cpx)->(real) : "imag_dc" PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + // Cannot convert real to int (must use nint or trunc) proc sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => fix(false) proc int(x:any_real)=0 :test "Cannot convert real to integer" => fix(false) proc lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => fix(false) + // Some numeric conversions not hard-coded proc cpx(x:real_num)=cpx(real(x)) proc scpx(x:real_num)=cpx(sreal(x)) @@ -580,6 +582,7 @@ proc string(x:any_int)=string(int64(x)) proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) proc int(x:fix(int))=x + // Abstract numeric types type any_int is sint,int,lint,int8,int16,int32,int64 type any_real is sreal,real @@ -589,6 +592,7 @@ type real_num is int_num, any_real type cpx_num is real_num,any_cpx type num is cpx_num + // Numeric type conversion proc convert(x,y)=x proc convert(x:int_num,y:sint)=sint(x) @@ -614,6 +618,8 @@ proc as(x:real_num,y:)=real(x) proc as(x:real_num,y:)=scpx(x) proc as(x:real_num,y:)=cpx(x) + + // Auto-conversion on assignment proc PM__assign(&x:num,y:num) { _assign_element(&x,convert(y,x)) @@ -623,6 +629,7 @@ proc PM__assign_var(&x:num,y:num) { PM__assign(&x,convert(y,x)) } + // Mixed arithmatic type _to_sint is int type _to_lint is sint,int @@ -682,11 +689,12 @@ proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) -proc xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y) +proc ~(x:num,y:num)=xx ~ yy where xx,yy=balance(x,y) proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) + // bool type PM__intrinsic PM__assign_var(&bool,bool): "assign_l" PM__intrinsic string(bool)->(string) : "string_l" @@ -696,8 +704,6 @@ PM__intrinsic not(bool)->(bool) : "not" PM__intrinsic ==(bool,bool)->(bool) : "eq_l" PM__intrinsic /=(bool,bool)->(bool) : "ne_l" -/* - // Masked types type masked(x) is rec {_val:x,_there:bool} proc |(x:masked,y)=if(x._there=>x._val,y) @@ -723,6 +729,8 @@ proc get(&x,y:masked(x)) { return y._there } + + // Polymorphic types PM__intrinsic get(x:*any,y:any)->(=y) : "as" PM__intrinsic<> get(&x:any,y:*any): "get_poly" @@ -732,6 +740,7 @@ PM__intrinsic<> |(x:*any,y:any)->(=y) : "get_poly_or" // val function having null effect proc val(x)=x + // ******************************************** // TUPLES // ******************************************** @@ -1062,6 +1071,7 @@ proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + // ***************************************************** // LISTS // ***************************************************** @@ -1073,7 +1083,8 @@ type _list_end is unique proc _cons(a,b)=new _list_node{_head=a,_tail=b} proc list(a)<>=_cons(a,_list_end) -proc list(a,arg...)<>=_cons(a,list(arg...)) +proc list(a,...)<>=_cons(a,list(...)) + proc reduce(p,a:_list_node)=p.(a._head,reduce(p,a._tail)) proc reduce(p,a:_list_node(,_list_end))=a._head @@ -1081,8 +1092,12 @@ proc reduce(p,a:_list_node(,_list_end))=a._head proc map(p,&a:_list_node){p.(a._head);map(p,a._tail)} proc map(p,&a:_list_node(,_list_end)):p.(a._head) + proc map(p,&a:_list_node(,_list_node),b:_list_node(,_list_node)){p.(&a._head,b._head);map(p,&a._tail,b._tail)} + + proc map(p,&a:_list_node(,_list_end),b:_list_node(,_list_end)):p.(&a._head,b._head) + proc map(p,&a:_list_node,b:_list_node): test "List lengths do not match"=>fix(false) proc map_const(p,&a:_list_node(,_list_node),b){p.(&a._head,b);map_const(p,&a._tail,b)} @@ -1113,6 +1128,9 @@ proc _list_elem(a:_list_node(,_list_end),b:fix(int),c:fix(int)) { return a._head } + +/* + // ***************************************************** // RANGES AND SEQUENCES // ***************************************************** @@ -1519,7 +1537,7 @@ proc _size(x:stretch_dim or null)=fix(1) proc _size(x)=size(x) PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" proc _act(x)=x -proc _sliceit(arg...)=tuple(arg...) +proc _sliceit(...)=tuple(...) proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) proc active_dims(x:single_point)=null PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" @@ -1533,8 +1551,8 @@ proc element(x:iterable_grid,y:index){ t=_tup(y) return _ges(head(x),tail(x),head(t),tail(t),fix(false)) } -proc element(x:grid_slice,arg...:grid_slice){ - t=_tup(arg...) +proc element(x:grid_slice,...:grid_slice){ + t=_tup(...) return _ges(head(x),tail(x),head(t),tail(t),fix(true)) } @@ -1585,6 +1603,7 @@ proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x) proc expand(x:grid_slice,y:grid)=map($expand,x,y) proc contact(x:grid_slice,y:grid)=map($contract,x,y) PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" + // ***************************************************** // SHAPES // ***************************************************** @@ -1604,17 +1623,19 @@ type mshape4d is mshape(extent4d) type mshape5d is mshape(extent5d) type mshape6d is mshape(extent6d) type mshape7d is mshape(extent7d) + // Create array, vector and matrix shapes proc _low(x)=low(x) proc _low(x:null)=fix(0) proc _off(x)=-index(dims(x),map($_low,x)) -proc PM__array(arg...)=shape(map($_extnt,[arg...])) +proc PM__array(...)=shape(map($_extnt,[...])) proc _extnt(n:any_int)=0..int(n)-1 proc _extnt(n:null)=null proc _extnt(n:range(any_int))=int(n) proc shape(extent:extent)=new mshape { _extent=extent,_n=size(extent),_o=_off(extent) } + // Conforming mshapes proc check_conform(x,y) { check_conform(#x,#y) @@ -1628,36 +1649,48 @@ proc _conform(x:null,y)=size(y)==fix(1) proc _conform(x,y:null)=fix(true) proc _conform(x:null,y:null)=fix(true) proc conform(x:mshape,y:mshape)=map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0check "Values of different ranks cannot conform"=>rank(x)==rank(y) + // Local size of a mshape proc _local_size(x:mshape)=size(x._extent) + // Convert an extent to have a zero base proc zero_base(x:range)=0..size(x)-1 proc zero_base(x:extent)=map($zero_base,x) + // Extent of a mshape proc extent(x:shape)=x._extent + // Dimensions of a mshape proc dims(x:mshape)=map($size,x._extent) + // Size from dimensions proc size(x:tuple(int))=reduce($*,x) + // Empty mshape proc _empty(x)=1..0 proc empty(x:extent)=map($_empty,x) + // Slice of mshape proc [](x:mshape,s:index)=x._extent[s] proc [](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,fix(true)))):check_contains(x,s) + + // ***************************************************** // INDEXING AND SLICING // ***************************************************** + // Generic types supporting indexing and mapping type iterable is iterable_grid,grid_slice,grid,grid_slice_dim,cyclic_range,array,... -proc [](x:iterable,arg...){ +proc [](x:iterable,...){ d=#x - y=_tup(arg...) + y=_tup(...) check_contains(d,y) return element(x,fill_in(d,y,fix(false))) } + // Index type type index is any_int,tuple(any_int) + // Slice and subscript types type range_below(x) is rec {_t:x} type range_above(x) is rec {_t:x} @@ -1668,6 +1701,7 @@ type slice_dim is range(any_int),strided_range(any_int),range_above(any_int), ra type slice is slice_dim,tuple(slice_dim) type subs_dim is slice_dim,any_int type subs is index,slice,subs_dim,tuple(subs_dim) + // Partial ranges/sequences mainly used in subscripts proc ..._(x)=new range_below { _t=x @@ -1696,6 +1730,7 @@ proc high(x:strided_range_below)=x._t proc step(x:range_above or range_below)=fix(1) proc step(x:strided_range_above or strided_range_below)=x._st proc width(x:strided_range_above or strided_range_below or range_above or range_below)=fix(1) + // Stretch dimension in subscript type stretch_dim is unique{PM__strdim} proc string(x:stretch_dim)="_" @@ -1713,18 +1748,19 @@ proc intersect(x:stretch_dim,y:stretch_dim)=x proc overlap(x:grid_slice_dim,y:stretch_dim)=#x proc overlap(x:stretch_dim,y:grid_slice_dim)=fix(0)..fix(0) proc overlap(x:stretch_dim,y:stretch_dim)=fix(0)..fix(0) + // Check subscript is in range -proc check_contains(a:extent,arg...) { - test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...) +proc check_contains(a:extent,...) { + test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(...) } -proc check_contains(a:mshape,arg...) { - check_contains(a._extent,arg...) +proc check_contains(a:mshape,...) { + check_contains(a._extent,...) } -proc check_contains(a,arg...) { - check_contains(#a,arg...) +proc check_contains(a,...) { + check_contains(#a,...) } -proc check_contains(a:dshape,arg...) { - check_contains(a._mshape._extent,arg...) +proc check_contains(a:dshape,...) { + check_contains(a._mshape._extent,...) } proc _contains(x:null,y)=fix(true) proc _contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y) @@ -1738,7 +1774,8 @@ PM__intrinsic _rgd(x:stretch_dim)->(PM__tinyint) : "miss_arg" proc _rgd(x)=x proc _rigid_dims(x:grid_slice or tuple(subs_dim))=map_apply($_rgd,$_sliceit,x) proc contains(x:extent,y:tuple(subs_dim) and contains(stretch_dim))=contains(x,_rigid_dims(y)) -proc contains(x:extent,y,arg...)=contains(x,[y,arg...]) +proc contains(x:extent,y,...)=contains(x,[y,...]) + // Complete a subscript using a base mshape proc fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => fix(false) proc fill_in(x:seq(int) or null,y:any_int,t:fix(true))=single_point(int(y)) @@ -1761,6 +1798,7 @@ proc _fill_in(x,y:stretch_dim,z,t:fix(false))=prepend(y,_fill_in(x,head(z),tail( proc _fill_in(x:null,y:empty_head,z,t)=null proc _fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t)) proc _fill_in(x:empty_head,y,z,t)=error_type() :test "Rank mismatch in slice" => fix(false) + // ******************************************************* // SUBSCRIPT INTERSECTION AND ALIASING // ******************************************************* @@ -1808,17 +1846,19 @@ proc intersects(x:tuple(subs_dim),y:null)=fix(true) proc intersects(x:null,y:tuple(subs_dim))=fix(true) proc _intersects(x:subs,y:subs)=intersects(x,y) proc _intersects(x,y)=fix(false) + // Alias checking -proc PM__check_alias(arg...)=false +proc PM__check_alias(...)=false proc PM__check_alias(i,j,x,y) { test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) } -proc PM__check_alias(i,j,x,y,arg...) { - if _intersects(x,y):PM__check_alias(i,j,arg...) +proc PM__check_alias(i,j,x,y,...) { + if _intersects(x,y):PM__check_alias(i,j,...) } + // Combining subscripts proc PM__cmbidx(x,y)=_cmb(x,y) -proc PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...) +proc PM__cmbidx(x,y,...)=PM__cmbidx(_cmb(x,y),...) type _cmb_error is unique proc _cmb(x,y)=_cmb_error proc _cmb(x:subs except index,y:subs)=_cmb1(x,y) @@ -1827,6 +1867,7 @@ proc _cmb1(x:subs_dim,y:subs_dim)=x[y] proc _cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y)) proc _cmb2(x,y,z:fix(true))=x[y] proc _cmb2(x,y,z:fix(false))=_cmb_error + // ******************************************************* // ITERATION - SEQUENTIAL AND CONCURRENT // ******************************************************* @@ -1840,6 +1881,7 @@ proc PM__first(d:tuple4d)=[j1,j2,j3,j4],[s1,s2,s3,s4],e1 and e2 and e3 and e4 wh proc PM__first(d:tuple5d)=[j1,j2,j3,j4,j5], [s1,s2,s3,s4,s5],e1 and e2 and e3 and e4 and e5 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5) proc PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],[s1,s2,s3,s4,s5,s6],e1 and e2 and e3 and e4 and e5 and e6 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6) proc PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],[s1,s2,s3,s4,s5,s6,s7],e1 and e2 and e3 and e4 and e5 and e6 and e7 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7) + // - subsequent elements proc PM__next(d:int,g,i)=ii,null,ii size(d)==a._s -proc element(a:array_template,arg...:subs)=a._a +proc element(a:array_template,...:subs)=a._a // Array creation from template proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) @@ -2332,12 +2374,12 @@ proc dims(dd:any^dshape)=dims((#dd)._mshape) proc PM__redim(a,d)=_redim(a,d) proc PM__local(a:any^dshape)=_redim(a,(#a)._tilesz) proc PM__local(a:any^mshape)=a -proc PM__local%(x:shared) shared =PM__local(x) +proc PM__local%(x:shrd) shrd =PM__local(x) proc element(a:any^dshape,t) { p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) var r=_arb(a) if p==_this_node():r=_get_aelem(a,i) - _bcast_shared(&r,p) + _bcast_shrd(&r,p) return r } @@ -2496,13 +2538,13 @@ proc _copy_array(&a:_non_d,x:any^dshape) { if i==_shrd_node() { forall kk in PM__local(x),j in tile { var k=kk - _bcast_shared(&k,i) + _bcast_shrd(&k,i) _set_elem(&a,k,(#a)[j] <>) } } else { forall j in tile { var k=_arb(a) - _bcast_shared(&k,i) + _bcast_shrd(&k,i) _set_elem(&a,k,(#a)[j] <>) } } @@ -2521,13 +2563,13 @@ proc _copy_array(&v:_non_d,x:array_slice(any^dshape,)) { if i==_shrd_node() { forall j in utile, jj in elem { var k=element(PM__local(x._a),j) - _bcast_shared(&k,i) + _bcast_shrd(&k,i) _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>) } } else { forall j in elem { var k=_arb(x._a) - _bcast_shared(&k,i) + _bcast_shrd(&k,i) _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>) } } @@ -2543,7 +2585,7 @@ proc _copy_array(&x:any^dshape,y:array_template) { _set_array(&^(PM__local(^(&x))),y._a) return fix(false) } -type _comp is contains(array or *any or ^*(,,,,)) +type _comp is contains(array or *any or PM__anyref(,,,,)) proc _copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) { _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#(xx._a),xd=#(x._a) return fix(true) @@ -2641,7 +2683,7 @@ proc _xp(x,y)=y // REFERENCES (SUBSCRIPTS AND SLICES) // ************************************************* // Reference type for & args -type PM__reftype(x) is x,^shared(x,,,,) +type PM__reftype(x) is x,PM__drefi(x,,,,) // Support for internal ^(...) reference type PM__intrinsic _v1(x:any)->(PM__d1 x) : "elem"(1) PM__intrinsic _v2(x:any)->(PM__d2 x) : "elem"(2) @@ -2662,7 +2704,7 @@ proc PM__subref(x,t:subs){ return _subref(x,tt) } proc PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x)) -proc PM__subref(x:^*(,,,,),t:null)=PM__subref(x,map($_make_null,#_v1(x))) +proc PM__subref(x:PM__anyref(,,,,),t:null)=PM__subref(x,map($_make_null,#_v1(x))) proc _subref(x:any^mshape,t:index)=element(x,t) proc _subref(x:any^any,t:subs)=new array_slice { _a=x,_s=fill_in(#x,t,fix(true)) @@ -2673,9 +2715,9 @@ proc _subref(x:array_slice,t:subs)=new array_slice { } proc _subref(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) proc _subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t]) -proc _subref(a:^*(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc _subref(a:PM__anyref(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) proc _subref(a,t)=$[](a,t) -proc [](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...))) +proc [](a:array,...)=PM__getref(PM__subref(a,_tup(...))) // Left hand side references proc PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) proc PM__sublhsamp(x,t:subs) { @@ -2694,12 +2736,12 @@ proc PM__sublhs(x,t:subs) { check_contains(#x,tt) return _sublhs(x,tt) } -proc PM__sublhs(x:^!(,,,,),t:subs) { +proc PM__sublhs(x:PM__ref(,,,,),t:subs) { tt=_tup(t) return _sublhs(x,tt) } proc PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x)) -proc PM__sublhs(x:^!(,,,,),t:null)=PM__sublhs(x,map($_make_null,#_v1(x))) +proc PM__sublhs(x:PM__ref(,,,,),t:null)=PM__sublhs(x,map($_make_null,#_v1(x))) proc _sublhs(x:any^mshape,t:index)=_make_subref(x,t) proc _sublhs(x:any^any,t:subs)=new array_slice { _a=x,_s=fill_in(#x,t,fix(true)) @@ -2709,31 +2751,35 @@ proc _sublhs(x:array_slice,t:subs)=new array_slice { _a=x._a,_s=x._s[t] } proc _sublhs(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) -proc _sublhs(a:^!(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) -proc [](&a:array,v,arg...){ - PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v) +proc _sublhs(a:PM__ref(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc [](&a:array,v,...){ + PM__assign(&^(PM__sublhs(^(&a),_tup(...))),v) } + +*/ // Realise a reference proc PM__valref(x)=x -proc PM__valref(x:^*(,,,,)) { + +/* +proc PM__valref(x:PM__anyref(,,,,)) { var v=_v1(x) if _v4(x)==_shrd_node() { v=_getref(x,null) } - _bcast_shared(&v,_v4(x)) + _bcast_shrd(&v,_v4(x)) return v } // Assign to a reference -proc PM__assign(&x:^*(,,,,),y) { +proc PM__assign(&x:PM__anyref(,,,,),y) { check_assign_types(_v1(^(&x)),y) if _v4(^(&x))==_shrd_node() { PM__assign(&^(_getlhs(^(&x),null)),y) } } -proc PM__assign(&x:^*(,,,,),y,p:assignment_operator) { +proc PM__assign(&x:PM__anyref(,,,,),y,p:assignment_operator) { if _v4(^(&x))==_shrd_node() { PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) } @@ -2765,7 +2811,7 @@ proc PM__sublhsamp%(x:any^dshape,t:subs) { } proc PM__sublhs%(x,y)=PM__subref%(x,y) -proc PM__sublhs%(x:priv ^*(,,,,),y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv PM__anyref(,,,,),y)=PM__subref%(x,y) proc PM__sublhs%(x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>fix(false) proc PM__subref%(x:priv,y)=PM__subref(x,y) proc PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y) @@ -2793,100 +2839,100 @@ proc PM__subref%(x:invar any^mshape,t:invar indexed)=PM__subref%(x,_dmap(t,here) proc PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t]) proc PM__subref%(x,t)=PM__dref($[](x,t),x,t,null,null) // Subscript or slice of distributed array -proc PM__subref%(x:shared any^dshape,t:invar index) complete <>{ +proc PM__subref%(x:shrd any^dshape,t:invar index) complete <>{ tt=_tup(t) check_contains(#(x),tt) return PM__dref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) } -proc PM__subref%(x:shared any^dshape,t:index){ +proc PM__subref%(x:shrd any^dshape,t:index){ tt=_tup(t) check_contains(#(x),tt) return PM__dref(_arb(x),x,i,p,_p_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) } -proc PM__subref%(x:shared any^dshape,t:subs){ +proc PM__subref%(x:shrd any^dshape,t:subs){ tt=_tup(t) check_contains(#(x),tt) var xx=varray(_arb(x),empty(#x)) return PM__drefs(xx,x,tt,p,_p_ref) where p=nodes_for_grid((#x).dist,tt) } -proc PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t) -proc PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond { +proc PM__subref%(x:shrd any^dshape,t:invar indexed) cond =PM__subref%(x,*t) +proc PM__subref%(region:shape(,blocked_distr),x:shrd any^dshape(,blocked_distr),t:invar indexed) uncond { check_contains(#x,_dmap(t,here)) return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t) } -proc PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t) +proc PM__subref%(x:shrd any^dshape,t:invar indexed) uncond =PM__subref%(x,*t) // Subscript or slice of non-distristuted array which is itself result of variant slice -proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index){ +proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:index){ tt=_tup(t) check_contains(#_v1%(x),tt) i=index(#(_v1%(x)),tt)return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null) } -proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){ +proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:invar index){ tt=_tup%(t) check_contains(#_v1%(x),tt) i=index(#(_v1%(x)),tt) return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null) } -proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) { +proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:subs) { tt=_tup(t) check_contains(#(_v1%(x)),tt) return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null) } -proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) // Subscript or slice of darray which is itself the result of a priv subscript -proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index){ +proc PM__subref%(x:priv PM__anyref(any^dshape,,,null,null),t:index){ tt=_tup(t) check_contains(#_v1%(x),tt) return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt) } -proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:subs){ +proc PM__subref%(x:priv PM__anyref(any^dshape,,,null,null),t:subs){ tt=_tup(t) check_contains(#_v1%(x),tt) return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) where p=nodes_for_grid((#_v1%(x)).dist,tt) } -proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +proc PM__subref%(x:priv PM__anyref(any^dshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) // Subscript of a priv slice -proc PM__subref%(x:priv ^#(,,,null,null),t:subs)=PM__subref%(_v2%(x),_v3%(x)[_tup(t)]) -proc PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)=PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here) +proc PM__subref%(x:priv PM__drefs(,,,null,null),t:subs)=PM__subref%(_v2%(x),_v3%(x)[_tup(t)]) +proc PM__subref%(x:priv PM__drefs(,,,null,null),t:invar indexed)=PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here) // Subscript of distributed reference proc _arb%(x:partial)=_arb(x) proc _arb%(x:complete) complete <>=_arb(x) proc _arb%(x:chan) complete <>=_arb(x) proc _arb%(x:invar) complete <>=_arb(x) -proc PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) -proc PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t)) -proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref) -proc PM__subref%(x:priv ^*(any^any,,,,),t:invar indexed)=PM__subref%(x,_dmap(_tup(t),here)) -proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) -proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) -proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) -proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref) +proc PM__subref%(x:priv PM__anyref(any^any,,,,),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv PM__anyref(any^any,,,,),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv PM__anyref(any^any,,,,_s_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref) +proc PM__subref%(x:priv PM__anyref(any^any,,,,),t:invar indexed)=PM__subref%(x,_dmap(_tup(t),here)) +proc PM__subref%(x:priv PM__anyref(any^any,,,,_s_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv PM__anyref(any^any,,,,_d_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv PM__anyref(any^any,,,,_d_ref),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv PM__anyref(any^any,,,,_d_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref) // Node .[] subscript of distributed array type _lcl is unique{_LCL} proc PM__nodelhs%(x,y)=PM__noderef%(x,y) -proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)=^(PM__import_val(PM__local(x)),coherent) -proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar any_int){ +proc PM__noderef%(region:dshape,x:shrd any^dshape,y:invar null)=^(PM__import_val(PM__local(x)),coherent) +proc PM__noderef%(region:dshape,x:shrd any^dshape,y:invar any_int){ xd=#((#x).dist) check_contains(xd,y) return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)where p=index(xd,int(y)) } -proc PM__noderef%(region:dshape,x:shared any^dshape,y:priv any_int){ +proc PM__noderef%(region:dshape,x:shrd any^dshape,y:priv any_int){ xd=#((#x).dist) check_contains(xd,y) return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)where p=index(xd,y) } -proc PM__noderef%(region:dshape,x:shared any^dshape,y:shared indexed)=PM__noderef%(x,*y) -proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:invar any_int){ +proc PM__noderef%(region:dshape,x:shrd any^dshape,y:shrd indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x:priv PM__anyref(any^dshape,,,null,null),y:invar any_int){ xd=#((#x).dist) check_contains(xd,y) return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)where p=index(xd,int(y)) } -proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:priv any_int){ +proc PM__noderef%(x:priv PM__anyref(any^dshape,,,null,null),y:priv any_int){ xd=#((#x).dist) check_contains(xd,y) return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)where p=index(xd,int(y)) } -proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x:priv PM__anyref(any^dshape,,,null,null),y:shrd indexed)=PM__noderef%(x,*y) proc PM__noderef%(x,y)=error_type() { if not region is { test """.[]"" subscript in non-distributed region"=>fix(false)} elseif x is { @@ -2915,12 +2961,12 @@ type _di(n) is indexed_dim(fix(1),fix(1),,n) or int type _dr is [_di(fix(1))],[_di(fix(1)),_di(fix(2))],[_di(fix(1)),_di(fix(2)),_di(fix(3))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5)),_di(fix(6))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5)),_di(fix(6)),_di(fix(7))] // Resolve a distributed reference proc PM__getref%(x,at)=x -proc PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x) -proc PM__getref%(x:priv ^*(,,,int,_p_ref),at) { +proc PM__getref%(x:priv PM__anyref(,,,null,null),at)=_v1%(x) +proc PM__getref%(x:priv PM__anyref(,,,int,_p_ref),at) { PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) return v } -proc PM__getref%(x:priv ^*(,,,int,_sp_ref),at) { +proc PM__getref%(x:priv PM__anyref(,,,int,_sp_ref),at) { PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) return v } @@ -2935,10 +2981,10 @@ proc _scatter(x,region) { } } -proc PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> { +proc PM__getref%(x:complete PM__anyref(,,,int,_s_ref),at:invar) complete <> { chan var xx=_v1%(x) _getref_s%(&xx!,^^(x),at) - _bcast_shared(&xx) + _bcast_shrd(&xx) return xx } proc _getref_s%(&xx:invar,x:invar,at:invar) PM__node { @@ -2948,10 +2994,10 @@ proc _getref_s%(&xx:invar,x:invar,at:invar) PM__node { _scatter(x,region) _sync_messages(xx,x) } -proc PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{ +proc PM__getref%(x:complete PM__anyref(_comp,,,int,_s_ref),at:invar) complete <>{ chan var xx=_v1%(x) _getref_sc%(&xx!,^^(x),at) - _bcast_shared(&xx) + _bcast_shrd(&xx) return xx } proc _getref_sc%(&xx:invar,x:invar,at:invar) PM__node { @@ -2961,20 +3007,20 @@ proc _getref_sc%(&xx:invar,x:invar,at:invar) PM__node { } _sync_messages(xx,x) } -proc PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> { +proc PM__getref%(x:complete PM__anyref(,PM__anyref(,,,,),,,_d_ref),at:invar) complete <> { chan var a=_v1%(x) _getref_d%(&^(PM__local%(^(&a!))),^^(x),at <>) - _bcast_shared(&a) + _bcast_shrd(&a) return a } proc _getref_d%(&a:invar,x:invar,at:invar) PM__node { _get_dindex_from_dref(&a,x,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) } -proc PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> { +proc PM__getref%(x:complete PM__anyref(,,,,_d_ref),at:invar) complete <> { chan var a=_arb(_v2%(x)) _getref_dc%(&a!,^^(x),at <>) - _bcast_shared(&a) + _bcast_shrd(&a) return a } proc _getref_dc%(&a:invar,x:invar,at:invar) PM__node { @@ -2983,10 +3029,10 @@ proc _getref_dc%(&a:invar,x:invar,at:invar) PM__node { } } -proc PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> { +proc PM__getref%(x:complete PM__anyref(,,,,_dp_ref),at:invar) complete <> { chan var a=_v1%(x) _getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>) - _bcast_shared(&a) + _bcast_shrd(&a) return a } proc _getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node { @@ -2994,7 +3040,7 @@ proc _getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node { _get_dindex_from_ref(&a,x,t.2, _local_region(region._tile,subregion(schedule)),region, t.1,atq,_drat(at,region._tile,t.1)) } } -proc PM__getref%(x:priv ^#(,,,,),at) { +proc PM__getref%(x:priv PM__drefs(,,,,),at) { var v=varray(_arb(_v1%(x)),#_v3%(x)) var vv=varray(_arb(_v1%(x)),empty(#_v1%(x))) foreach p in _v4%(x) { @@ -3010,14 +3056,14 @@ proc PM__getref%(x:priv ^#(,,,,),at) { // Resolve reference locally (once communicated) proc _getref_elem(x:any^mshape,i)=_get_aelem(x,i) proc _getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i) -proc _getref(x:^*(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x)) -proc _getref(x:^*(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here) -proc _getref(x:^*(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)] -proc _getref(x:^*(,,null,,),y)<>=_getref(_v2(x),y) -proc _getref(x:^*(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y)) +proc _getref(x:PM__anyref(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x)) +proc _getref(x:PM__anyref(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here) +proc _getref(x:PM__anyref(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)] +proc _getref(x:PM__anyref(,,null,,),y)<>=_getref(_v2(x),y) +proc _getref(x:PM__anyref(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y)) proc _getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x) -proc _getref(x:^shared(,null,null,null,null),y)<>=_v1(x) -proc _getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x)) +proc _getref(x:PM__drefi(,null,null,null,null),y)<>=_v1(x) +proc _getref(x:PM__drefs(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x)) proc _getslice(x:any^dshape,tt) { t=overlap((#x)._tile,tt) var v=varray(_arb(x),#t) @@ -3030,16 +3076,16 @@ proc _getslice(x:any^mshape,t) { return v } proc _getref(x:any^any,y)=x -proc _getref(x:^shared(,,indexed,,),y)<>=_getref(_v2(x),y)[_dmap(_v3(x),y)] -proc _getref(x:^shared(,any^dshape,indexed,,),y)<>=element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) -proc _getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) :test "Internal error - uncapped dref" => fix(false) +proc _getref(x:PM__drefi(,,indexed,,),y)<>=_getref(_v2(x),y)[_dmap(_v3(x),y)] +proc _getref(x:PM__drefi(,any^dshape,indexed,,),y)<>=element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getref(x:PM__drefi(,,indexed,,),y:null)<>=_v1(x) :test "Internal error - uncapped dref" => fix(false) PM__if_compiling PM__intrinsic _sync%(any,any,any,&x:any): "sync" PM__else proc _sync%(&x:any){ } PM__endif -// Assignment of distributed and/or shared or uniform references +// Assignment of distributed and/or shrd or uniform references proc PM__assign%(&x:priv,y,at) { _sync%(&x) PM__assign(&x,y <>) @@ -3052,7 +3098,7 @@ proc _assign_to_invar%(&x:uniform,y:invar) complete { PM__assign(&x,y <>) } -proc _assign_to_invar%(&x:shared,y:invar) shared{ +proc _assign_to_invar%(&x:shrd,y:invar) shrd{ PM__assign(&x,y) } @@ -3060,7 +3106,7 @@ proc _assign_to_invar%(&x:invar,y:priv) { test "Can only assign an ""invar"" value to an ""invar"" variable" => fix(false) } -proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y,at) { PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy) } @@ -3069,13 +3115,13 @@ proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) { } } -proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y:invar,at) { PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y) } } -proc PM__assign%(&x:priv ^*(,,,null,null),y,at) { +proc PM__assign%(&x:priv PM__anyref(,,,null,null),y,at) { foreach invar p in 0..size(#region.dist)-1 { PM__bcast xx,yy,_cap%(x,here),y,p { PM__assign(&^(_getlhs(^(&xx),null)),yy) @@ -3088,16 +3134,16 @@ proc PM__assign%(&x:priv ^*(,,,null,null),y,at) { } } -proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,at) { +proc PM__assign%(&x:priv PM__anyref(,,,null,null),y:invar,at) { _sync%(&x) var xx=_import_dref%(x) PM__assign(&^(_getlhs(^(&xx),here)),y) } -proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,at) { +proc PM__assign%(&x:priv PM__anyref(,null,null,null,null),y:invar,at) { _sync%(&x) PM__assign(&^(_v1%(^(&x))),y) } -proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref or _s_ref),y,at) { PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy) } @@ -3106,13 +3152,13 @@ proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) { } } -proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:invar,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref or _s_ref),y:invar,at) { PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y)) } } -proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) { +proc PM__assign%(&x:priv PM__anyref(,,,,_d_ref or _dp_ref),y,at) { _set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)), $_just_assign,^^(^??),at,_v4(x) <>) } */ @@ -3137,26 +3183,26 @@ proc _assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete{ PM__assign(&x,y,pr <>) } -proc _assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared { +proc _assign_to_invar%(&x:shrd,y:invar,pr:uniform,at:uniform) shrd { PM__assign(&x,y,pr) } proc _assign_to_invar%(&x:invar,y:priv,pr,at){ _assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at) } -proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y,pr,at) { PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) } } -proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y:invar,pr,at) { PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr) } } -proc PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,null,null),y:priv,pr,at) { foreach invar p in 0..size(region.dist)-1 { PM__bcast xx,yy,_cap%(x,here),y,p { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) @@ -3164,47 +3210,47 @@ proc PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) { } } -proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,null,null),y:invar,pr,at) { var xx=_import_dref%(x) PM__assign(&^(_getlhs(^(&xx),here)),y,pr) } -proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,null,null,null,null),y:invar,pr,at) { PM__assign(&^(_v1%(^(&x))),y,pr) } -proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:priv,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref or _s_ref),y:priv,pr,at) { PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) } } -proc PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref),y:invar,pr,at) { PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr) } } -proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) { +proc PM__assign%(&x:priv PM__anyref(,,,,_d_ref or _dp_ref),y:priv,pr,at) { _set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,pr,^^(^??),at <>)where t=_v4%(x) } // Resolve LHS reference (locally after communication) -proc _getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here) -proc _getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y) -proc _getlhs(x:^(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) -proc _getlhs(x:^shared(,,null,,),y)=_getlhs(_v2(x),y) -proc _getlhs(x:^shared(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) -proc _getlhs(x:^(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) -proc _getlhs(x:^shared(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _getlhs(x:PM__anyref(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here) +proc _getlhs(x:PM__anyref(,,_lcl,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:PM__dref(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:PM__drefi(,,null,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:PM__drefi(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:PM__dref(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _getlhs(x:PM__drefi(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) proc _local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t)) -proc _getlhs(x:^#(,,subs,,),y)<>=_local_ref(x,_v3(x)) -proc _getlhs(x:^#shared(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:PM__drefs(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:PM__dref_is(,,subs,,),y)<>=_local_ref(x,_v3(x)) proc _getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x) -proc _getlhs(x:^shared(,null,null,null,null),y)<>=_v1(x) -proc _getlhs(x:^(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:PM__drefi(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:PM__dref(,null,null,null,null),y)<>=_v1(x) proc _getlhs(x:any^any,y)=x proc _getlhs(x:any^dshape,y)=PM__local(x) -proc _getlhs(x:^shared(,,indexed,,),y)<>=_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y)) -proc _getlhs(x:^shared(,any^dshape,indexed,,),y)<>=_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) -proc _getlhs(x:^shared(,,indexed,,),y:null)=_v1(x) :test "Internal error -- uncapped indexed ref" => fix(false) +proc _getlhs(x:PM__drefi(,,indexed,,),y)<>=_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y)) +proc _getlhs(x:PM__drefi(,any^dshape,indexed,,),y)<>=_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getlhs(x:PM__drefi(,,indexed,,),y:null)=_v1(x) :test "Internal error -- uncapped indexed ref" => fix(false) // ************************************************************** // INDEXED VARIABLES // ************************************************************** @@ -3445,7 +3491,7 @@ proc _get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) PM__head_node{ _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send)) } - if at:_bcast_slice_shared(&b,active_dims(src_range,portion_to_send)) + if at:_bcast_slice_shrd(&b,active_dims(src_range,portion_to_send)) } } } @@ -3471,7 +3517,7 @@ proc _copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) { } } -// Resolve x[ indexed ][ indexed or shared ] ... +// Resolve x[ indexed ][ indexed or shrd ] ... proc _get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) { t=_correct(tt,shapex._mshape) shapexx=#shapex._mshape @@ -3510,7 +3556,7 @@ proc _get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexe _sync_messages(a,x) } -// Resolve x[ indexed ][ indexed or shared ] ... +// Resolve x[ indexed ][ indexed or shrd ] ... proc _get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) { t=_correct(tt,shapex._mshape) shapexx=#shapex._mshape @@ -3546,7 +3592,7 @@ proc _get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:in PM__head_node{ _recv_slice_sync(i,&a,portion_to_recv) } - if at:_bcast_slice_shared(&a,portion_to_recv) + if at:_bcast_slice_shrd(&a,portion_to_recv) } } } @@ -3649,12 +3695,12 @@ proc string(x:envelope)=string(x.cross++" ortho "++x.corner) // ************************************************************** type _nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits} type nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here} -proc PM__nhd%(x:invar envelope or extent,bound:invar) shared <>=new _nhd { +proc PM__nhd%(x:invar envelope or extent,bound:invar) shrd <>=new _nhd { _nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),_limits=_expand_limits(region._extent,envelope(x),bound)} where t=_get_halo(region,region._tile,envelope(x)) proc PM__nhd%(x,bound:invar)=^(new _nhd { _nbhd=n,_tile=t,_tilesz=#t,_interior=t,_limits=region._extent } -,shared) where t=region._tile where n=xx where xx=spread(0..0,here){ +,shrd) where t=region._tile where n=xx where xx=spread(0..0,here){ _check_nhd%(x) } proc _check_nhd%(n:invar envelope or extent) { @@ -3688,7 +3734,7 @@ proc PM__nhd_join(x,y)=new _join{ head=x,tail=y._array } proc PM__nhd_var%(x,n:_nhd,i,h)<>=new nbhd{ - _array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h + _array=_make_nhd%(^(x,shrd),n._tilesz),_nbhd=n,_index=i,_here=h } proc PM__nhd_active(region,nbhd,bound:null)=region._extent proc PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound) @@ -3699,7 +3745,7 @@ proc PM__nhd_active(region,nbhd,bound){ proc _nhd_active(r,n,b:CYCLE or null)=r proc _nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b)) proc _nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n) -proc _make_nhd%(x:invar,d:invar) shared <>{ +proc _make_nhd%(x:invar,d:invar) shrd <>{ var v=array(x,d) return v } @@ -3726,7 +3772,7 @@ proc PM__blocking%(x:tuple(any_int)){ test "Block sizes must be positive"=>map_reduce($_positive,$and,x) } proc _positive(x)=x>0 -proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { +proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shrd <> { PM__head_node{ this_tile=region._tile this_tile_x=nbhd._tile @@ -3757,7 +3803,7 @@ proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { } } -proc PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { +proc PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shrd <> { PM__head_node{ this_tile=region._tile this_tile_x=nbhd._tile @@ -3783,13 +3829,13 @@ proc outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y)) whe proc outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y) proc _foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner) proc _foot(d,n:extent)=n -proc PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { +proc PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shrd <> { PM__head_node{ _apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(true)) } } -proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { +proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shrd <> { PM__head_node{ this_tile=region._tile this_tile_x=nbhd._tile @@ -3809,11 +3855,11 @@ proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { +proc PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shrd <> { if shrd_nnode()>1 { foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 { chunk=chunk(region,envelope(nbhd._nbhd),i,b) - _bcast_slice_shared(&a,chunk) + _bcast_slice_shrd(&a,chunk) } } } @@ -3916,9 +3962,9 @@ proc _recv_slice_sync(p,&a:_join,o){ _recv_slice_sync(p,&a.head,o) _recv_slice_sync(p,&a.tail,o) } -proc _bcast_slice_shared(&a:_join,o) { - _bcast_slice_shared(&a.head,o) - _bcast_slice_shared(&a.tail,o) +proc _bcast_slice_shrd(&a:_join,o) { + _bcast_slice_shrd(&a.head,o) + _bcast_slice_shrd(&a.tail,o) } proc _sync_messages(x:_join):_sync_messages(x.head,x.tail) proc _not_zero(x)=if(x/=0=>1,0) @@ -4079,7 +4125,7 @@ proc _get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) { type disp_index is any_int,tuple(any_int) type disp_sub is disp_index,tuple(any_int or range(any_int)) // *** Default *** -proc nbr%(x:chan,t:shared disp_index,v:shared){ +proc nbr%(x:chan,t:shrd disp_index,v:shrd){ test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) j=displace(region._mshape,here,t) var y=v @@ -4089,7 +4135,7 @@ proc nbr%(x:chan,t:shared disp_index,v:shared){ return y } -proc nbhd%(x:chan,t:shared disp_sub,v:shared) { +proc nbhd%(x:chan,t:shrd disp_sub,v:shrd) { test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) var a=array(v,#t) foreach invar i in t { @@ -4102,14 +4148,14 @@ proc nbhd%(x:chan,t:shared disp_sub,v:shared) { } // *** Blocked distributions *** -proc nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) { +proc nbr%(region:dshape(,blocked_distr),x:chan,t:shrd disp_index,v:shrd) { test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) var j=displace(region._mshape,here,t) a,ad=tile_with_halo%(x,t,v) return a[ad#j] } -proc nbhd%(region:dshape(,blocked_distr),x:chan,t:shared disp_sub,v:shared){ +proc nbhd%(region:dshape(,blocked_distr),x:chan,t:shrd disp_sub,v:shrd){ test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) a=displace(region._mshape,here,t) y,yd=tile_with_halo%(x,t,v) @@ -4422,11 +4468,11 @@ proc PM__set_elem%(&x:invar,v:complete,i,h){ PM__setelem(&x,v,h <>) _assemble%(&x,region) } -proc PM__get_elem%(x:shared any^dshape,i,h)=element(PM__local(x),i) +proc PM__get_elem%(x:shrd any^dshape,i,h)=element(PM__local(x),i) proc PM__set_elem%(&x:invar any^dshape,v:complete,i,h) { _set_elem(&^(PM__local(^(&x))),v,i <>) } -proc PM__get_elem%(x:shared array_slice(any^dshape),j,h)=_get_aelem(x._a,i) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +proc PM__get_elem%(x:shrd array_slice(any^dshape),j,h)=_get_aelem(x._a,i) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) proc PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){ PM__setaelem(&x._a,i,v <>) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) } @@ -4435,7 +4481,7 @@ proc _assemble%(&a:invar any^mshape,xregion:invar mshape) { } proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) { } -proc _assemble%(&a:invar any^mshape,xregion:invar) shared <> { +proc _assemble%(&a:invar any^mshape,xregion:invar) shrd <> { dist=xregion.dist foreach p in #(dist) { tile=dist[p] @@ -4455,7 +4501,7 @@ proc _assemble%(&a:invar any^mshape,xregion:invar) shared <> { } } -proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> { +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar) shrd <> { dist=xregion.dist foreach p in #(dist) { tile=intersect((#(a._a))#a._s,dist[p]) @@ -4482,12 +4528,12 @@ proc PM__get_tilesz(d:mshape)=d,size(d) PM__if_compiling proc PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region)) proc PM__makearray%(x:priv)=_makearray(x,region,size(region)):test "Can only apply ""!"" to a ""chan"" " => fix(false) -proc PM__makearray%(x:invar)=_makearray(x,region,size(region)):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => fix(false) +proc PM__makearray%(x:invar)=_makearray(x,region,size(region)):test "Cannot apply ""!"" to a ""shrd"" or ""uniform"" value" => fix(false) PM__intrinsic<> _makearray(x:any,y:any,z:any)->(PM__invar_dim x,y) : "make_array" PM__else proc PM__makearray%(x:chan) complete <>=_makearray(x,region) proc PM__makearray%(x:priv)=_makearray(x,region):test "Can only apply ""!"" to a ""chan"" " => fix(false) -proc PM__makearray%(x:invar)=_makearray(x,region):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => fix(false) +proc PM__makearray%(x:invar)=_makearray(x,region):test "Cannot apply ""!"" to a ""shrd"" or ""uniform"" value" => fix(false) PM__intrinsic<> _makearray(x:any,y:any)->(PM__dim x,y) : "make_array" PM__endif // active%() intrinsic @@ -4508,17 +4554,17 @@ proc PM__impscalar(x) { PM__checkimp(x) return _import_scalar(x) } -proc PM__import_val(x:^*(,,,,)) { +proc PM__import_val(x:PM__anyref(,,,,)) { test "Compiler internal error:importing reference" => fix(false) return x } -proc PM__impscalar(x:^*(,,,,)) { +proc PM__impscalar(x:PM__anyref(,,,,)) { test "Compiler internal error:importing reference" => fix(false) return x } -proc PM__checkimp(x,arg...) { +proc PM__checkimp(x,...) { PM__checkimp(x) - PM__checkimp(arg...) + PM__checkimp(...) } proc PM__checkimp(x) { } @@ -4530,14 +4576,14 @@ proc subregion(schedule:schedule)=schedule._subregion proc subregion(schedule:null)=null proc subtile(schedule:schedule)=schedule._subtile // Over statements -proc PM__over%(schedule:null,x:invar,block:invar) shared <>=new schedule{ +proc PM__over%(schedule:null,x:invar,block:invar) shrd <>=new schedule{ _subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region) } -proc PM__over%(x:invar,block:invar) shared <>=new schedule{ +proc PM__over%(x:invar,block:invar) shrd <>=new schedule{ _subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(x,schedule._subregion) -proc PM__make_over%(schedule:null,x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +proc PM__make_over%(schedule:null,x:invar tuple(subs_dim except stretch_dim),block:invar) shrd <>=new schedule{ _subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s where s=fill_in(region._extent,x,null) -proc PM__make_over%(x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +proc PM__make_over%(x:invar tuple(subs_dim except stretch_dim),block:invar) shrd <>=new schedule{ _subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(map($norm,fill_in(region._extent,x,fix(true))),schedule._subregion) proc PM__make_over%(x:invar,block)=x check "Expression in an ""over"" statement must be a subscript tuple"=>fix(false) proc PM__make_over%(x,block)=x check "Expression in an ""over"" statement must be ""invar"""=>fix(false) @@ -4573,7 +4619,7 @@ proc PM__do_over%(x:invar grid) complete <>{ } proc PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x -proc _in%(x:invar,&t:invar) shared <>{ +proc _in%(x:invar,&t:invar) shrd <>{ forall i in x { sync t[i]=true } @@ -4585,15 +4631,15 @@ PM__intrinsic sys_nnode()->(int) : "sys_nnode" PM__intrinsic _this_node()->(int) : "this_node"(1) PM__intrinsic this_node%(r:any,s:any,h:any)->(int) : "this_node"(2) PM__intrinsic this_nnode()->(int) : "this_nnode" -PM__intrinsic _shrd_node()->(int) : "shared_node" -PM__intrinsic shrd_nnode()->(int) : "shared_nnode" +PM__intrinsic _shrd_node()->(int) : "shrd_node" +PM__intrinsic shrd_nnode()->(int) : "shrd_nnode" PM__intrinsic _root_node()->(int) : "root_node" -PM__intrinsic is_shrd()->(bool) : "is_shared" -PM__intrinsic is_shrd(any)->(bool) : "is_shared" +PM__intrinsic is_shrd()->(bool) : "is_shrd" +PM__intrinsic is_shrd(any)->(bool) : "is_shrd" PM__intrinsic is_par()->(bool) : "is_par" proc _head_node()=_shrd_node()==0 // Parallel system nested contexts -PM__intrinsic<> _push_node_grid(arg...:any): "push_node_grid" +PM__intrinsic<> _push_node_grid(...:any): "push_node_grid" proc _push_node(d:int,t:int){ _push_node_grid(false,t) } @@ -4760,11 +4806,11 @@ proc write(&f:file,x:io_type^dshape) { } // Distributed I/O proc partition%(f:filesystem)=f:test "Partition not yet implemented"=>fix(false) -proc read%(&f:shared file,&x:complete io_type){ +proc read%(&f:shrd file,&x:complete io_type){ err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape)) return _make_file_error(err) } -proc write%(&f:shared file,x:complete io_type){ +proc write%(&f:shrd file,x:complete io_type){ err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape)) return _make_file_error(err) } @@ -4792,11 +4838,11 @@ proc seek(&f:file,x:lint) { error=seek(&f,x) test "Error on seek:"++error=>not(error) } -proc read%(&f:shared file,&x) { +proc read%(&f:shrd file,&x) { error=read%(&f,&x) test "Error reading from file:"++error=>not(error) } -proc write%(&f:shared file,x) { +proc write%(&f:shrd file,x) { error=write%(&f,x) test "Error writing to file:"=>not(error) } @@ -4898,8 +4944,8 @@ proc _recv_slice_sync(p,&x,d) { _recv_offset(_norm(dims(x),d),p,&x) } -proc _bcast_slice_shared(&x,d){ - _bcast_shared_offset(_norm(dims(x),d),&x) +proc _bcast_slice_shrd(&x,d){ + _bcast_shrd_offset(_norm(dims(x),d),&x) } proc _send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^(fix(true))) { forall i in d { @@ -4954,8 +5000,8 @@ PM__intrinsic<> _irecv_offset%(r:any,s:any,h:any,j:any,p:any PM__intrinsic<> _irecv_offset(j:any,p:any,&x:any): "irecv_grid" PM__intrinsic<> _recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_offset" PM__intrinsic<> _recv_offset(j:any,p:any,&x:any): "recv_grid" -PM__intrinsic<> _bcast_shared_offset%(r:any,s:any,h:any,j:any,&x:any): "bcast_shared_offset" -PM__intrinsic<> _bcast_shared_offset(j:any,&x:any): "bcast_shared_grid" +PM__intrinsic<> _bcast_shrd_offset%(r:any,s:any,h:any,j:any,&x:any): "bcast_shrd_offset" +PM__intrinsic<> _bcast_shrd_offset(j:any,&x:any): "bcast_shrd_grid" PM__intrinsic<> _isend(p:any,x:any): "isend" PM__intrinsic<> _irecv(p:any,&x:any): "irecv" PM__intrinsic<> _recv(p:any,&x:any): "recv" @@ -4968,9 +5014,9 @@ PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any): "recv_reply" PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_reply" PM__intrinsic<> _recv_reply(j:any,p:any,&x:any): "recv_reply" -PM__intrinsic<> _bcast_shared(&x:any): "broadcast_shared" -PM__intrinsic<> _bcast_shared(&x:any,p:int): "broadcast_shared" -type _ct is array_slice,^*(,,,,),any^any,^^(any) +PM__intrinsic<> _bcast_shrd(&x:any): "broadcast_shrd" +PM__intrinsic<> _bcast_shrd(&x:any,p:int): "broadcast_shrd" +type _ct is array_slice,PM__anyref(,,,,),any^any,^^(any) proc PM__sync_messages(x)<>:_sync_messages(x) PM__if_compiling proc _sync_messages(x:_ct):_do_sync_messages(_core(x)) @@ -4978,19 +5024,19 @@ proc _sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y)) proc _core(x:any^any)=x proc _core(x:^^(any))=x proc _core(x:array_slice)=_core(x._a) -proc _core(x:^*(,,,,))=_core(_v2(x)) -PM__intrinsic<> _do_sync_messages(arg...:^^(any) or any^any): "sync_mess" +proc _core(x:PM__anyref(,,,,))=_core(_v2(x)) +PM__intrinsic<> _do_sync_messages(...:^^(any) or any^any): "sync_mess" PM__else -PM__intrinsic<> _sync_messages(arg...:_ct): "sync_mess" +PM__intrinsic<> _sync_messages(...:_ct): "sync_mess" PM__endif proc _tup(x:tuple)=x -proc _tup(arg...)=tuple(arg...) +proc _tup(...)=tuple(...) proc _tup(x:null)=x -proc _tup%(x:invar) shared=_tup(x) +proc _tup%(x:invar) shrd=_tup(x) PM__intrinsic<> PM__broadcast(&b:any,a:int): "broadcast" PM__intrinsic<> PM__broadcast(b:any,a:int)->(=b) : "broadcast_val" -PM__intrinsic<> get_remote%(r:any,s:any,h:any,a:shared any^dshape,b:int,c:int)->(%a) : "get_remote_distr" -PM__intrinsic<> put_remote%(r:any,s:any,h:any,a:shared any^dshape,b:any,c:int,d:int): "put_remote_distr" +PM__intrinsic<> get_remote%(r:any,s:any,h:any,a:shrd any^dshape,b:int,c:int)->(%a) : "get_remote_distr" +PM__intrinsic<> put_remote%(r:any,s:any,h:any,a:shrd any^dshape,b:any,c:int,d:int): "put_remote_distr" // ******************************************************** // OTHER COMMUNICATING & ARRAY OPERATIONS // ******************************************************** @@ -5039,7 +5085,7 @@ proc pack(vv:array,mm:array) { } // Reduction -type associative_proc is $+,$*,$max,$min,$&,$|,$xor,$++,$==,... +type associative_proc is $+,$*,$max,$min,$&,$|,$~,$++,$==,... PM__if_compiling proc reduce(p:proc,x:array(,mshape)) { var s=_get_aelem(x,0) @@ -5086,7 +5132,7 @@ proc _reduce(p:proc,y) { var n=this_nnode() var i=1 until i>n-1 { - other=_this_node() xor i + other=_this_node() ~ i if other>=a { @@ -5166,7 +5212,7 @@ proc PM__assign(&a:any,b:any) { _assign(&a,c) where c=b as a } -type assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,... +type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... proc PM__assign(&a:any,b:any,c:assignment_operator) { PM__assign(&a,c.(a,b)) @@ -5187,25 +5233,34 @@ proc _assign(&a,b) { proc _assign(&a:contains(farray),b) { _assign_structure(&a,b) } -*/ proc _assign_structure(&a,b)<>{ _assign_element(&a,b) } proc _assign_structure(&a:farray,b){ _array_assign(&a,b,fix(true)) } +*/ PM__intrinsic _assign_element(&any,any): "assign" // Other variable operations PM__intrinsic PM__clone(x:any)->(=x) : "clone" -proc PM__dup(PM__dup) <>=PM__clone(PM__dup) +//proc PM__dup(PM__dup) <>=PM__clone(PM__dup) +proc PM__dup(PM__dup)=PM__clone(PM__dup) +/* PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" +PM__intrinsic PM__dup(x:literal(int))->(int) : "clone" +PM__intrinsic PM__dup(x:literal(real))->(real) : "clone" +PM__intrinsic PM__dup(x:literal(string))->(string) : "clone" +PM__intrinsic PM__dup(x:literal(bool))->(bool) : "clone" +*/ PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" + +/* proc ==(x:any,y:any) { test "Cannot apply ""=="" to different types"=> same_type(x,y) var ok=true @@ -5221,13 +5276,14 @@ proc /=(x:any,y:any) { proc _eq(x:any,y:any,&ok) <> { ok=ok and x==y } +*/ PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" proc next_enum(x:int)=x+convert(1,x) proc next_enum(x:int,y:int)=x+convert(y,x) -PM__intrinsic<> PM__element_at(x:any,y:literal(int))->(|x):"elem" +PM__intrinsic<> .element_at_index(o:any,r:any,s:any,h:any,m:any,&x:any,y:fix(int))->(|x):"elem" proc elements(x)=_elements(x,1) proc _elements(x,i:literal(int)) { @@ -5254,6 +5310,7 @@ PM__intrinsic<> error_type()->(?0) : "call" PM__intrinsic<> _dump(any,any): "new_dump" proc PM__dump(x)<>:_dump("Value:",x) proc PM__dump(y,x)<>:if y:_dump("Value:",x) +/* proc PM__dump%(x)<>{ print("$"++here) _dump(string(here),x) @@ -5265,6 +5322,7 @@ proc PM__dump%(y,x){ test "Selection expression in ""$$dump"" not ""bool""" => fix(false) $$infer_type(y) } +*/ PM__intrinsic<> old_dump(any): "dump" proc old_dumpit(a) { old_dump(a) @@ -5273,4 +5331,4 @@ proc old_dumpit(a) { PM__intrinsic<> old_dump_id(any): "dump_id" -proc PM__filesys()=1 +proc PM__filesys()=1234 diff --git a/src/ast.f90 b/src/ast.f90 index cb82223..0478f73 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -38,6 +38,9 @@ module pm_ast use pm_vmdefs use pm_types + ! Langauge features + integer,parameter:: num_comm_args=6 + ! Offsets into module objects integer,parameter:: modl_name=1 integer,parameter:: modl_link=2 @@ -76,13 +79,11 @@ module pm_ast integer,parameter:: proc_params=node_args+4 integer,parameter:: proc_keys=node_args+5 integer,parameter:: proc_amplocs=node_args+6 - integer,parameter:: proc_coded_params=node_args+7 + integer,parameter:: proc_when=node_args+7 integer,parameter:: proc_coded_results=node_args+8 integer,parameter:: proc_coded_type=node_args+9 integer,parameter:: proc_numret=node_args+10 integer,parameter:: proc_result_types=node_args+11 - - ! Alternative final sections for 'proc' parse nodes @@ -102,27 +103,28 @@ module pm_ast integer,parameter:: proc_coded_builtin=node_args+16 integer,parameter:: sysproc_num_args=17 - ! Values for proc flags - integer,parameter:: proc_is_comm= 1 - integer,parameter:: proc_run_complete= 2 - integer,parameter:: proc_run_local= 4 - integer,parameter:: proc_run_shared= 8 - integer,parameter:: proc_run_always= 16 - integer,parameter:: proc_inline= 32 - integer,parameter:: proc_no_inline= 64 - integer,parameter:: proc_is_open= 128 - integer,parameter:: proc_is_each_proc= 256 - integer,parameter:: proc_is_cond= 512 - integer,parameter:: proc_is_uncond= 1024 - integer,parameter:: proc_is_abstract= 2048 - integer,parameter:: proc_is_thru_each = 2**12 - integer,parameter:: proc_is_empty_each = 2**13 - integer,parameter:: proc_is_dup_each = 2**14 - integer,parameter:: proc_is_var = 2**15 + ! Values for proc flags + integer,parameter:: proccall_is_comm= 1 + integer,parameter:: proccall_is_ref = 2 + integer,parameter:: proccall_is_general = 4 + integer,parameter:: proccall_is_yield = 8 + + integer,parameter:: proccall_is_inline= 16 + integer,parameter:: proccall_is_no_inline= 32 + + integer,parameter:: proc_is_cond= 256 + integer,parameter:: proc_is_uncond= 512 + integer,parameter:: proc_run_complete= 2**10 + integer,parameter:: proc_run_local= 2**11 + integer,parameter:: proc_run_shared= 2**12 + integer,parameter:: proc_run_always= 2**13 + integer,parameter:: proc_is_open= 2**14 + integer,parameter:: proc_is_abstract= 2**15 integer,parameter:: proc_is_generator = 2**16 integer,parameter:: proc_needs_type = 2**17 integer,parameter:: proc_is_recursive = 2**18 integer,parameter:: proc_unfinished = 2**19 + integer,parameter:: proc_is_impure = 2**20 integer,parameter:: proc_is_not_inlinable = 2**21 integer,parameter:: proc_has_for = 2**22 @@ -130,26 +132,24 @@ module pm_ast integer,parameter:: proc_has_vkeys = 2**24 integer,parameter:: proc_is_dcomm = 2**25 integer,parameter:: proc_is_file = 2**26 - integer,parameter:: proc_needs_par = 2**27 - integer,parameter:: proc_prints_out = 2**28 + integer,parameter:: proc_prints_out = 2**27 ! Proc flags that can be taken as taints integer,parameter:: proc_taints = proc_is_impure & + proc_is_not_inlinable + proc_has_for & - + proc_is_not_pure_each + proc_is_dcomm + proc_is_file & - + proc_needs_par + proc_prints_out + + proc_is_dcomm + proc_is_file & + + proc_prints_out ! Flags for proc calls - integer,parameter:: call_is_comm=1 - integer,parameter:: call_ignore_rules=256 - integer,parameter:: call_is_fixed = 2**10 - integer,parameter:: call_is_assign_call = 2**11 - integer,parameter:: call_is_vararg = 2**12 + integer,parameter:: call_ignore_rules= 512 + integer,parameter:: call_is_fixed = 2**10 + integer,parameter:: call_is_assign_call = 2**11 + integer,parameter:: call_is_vararg = 2**12 integer,parameter:: call_inline_when_compiling = 2**13 - integer,parameter:: call_dup_result = 2**14 - integer,parameter:: call_is_cond = 2**15 - integer,parameter:: call_is_no_touch = 2**16 - integer,parameter:: call_is_unlabelled = 2**17 + integer,parameter:: call_dup_result = 2**14 + integer,parameter:: call_is_cond = 2**15 + integer,parameter:: call_is_no_touch = 2**16 + integer,parameter:: call_is_unlabelled = 2**17 integer,parameter:: call_is_uninitialised = 2**18 contains diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 555fc8e..2fa7e2b 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -169,7 +169,9 @@ module pm_cnodes integer,parameter:: pr_keys=cnode_args+12 integer,parameter:: pr_keycall=cnode_args+13 integer,parameter:: pr_argcall=cnode_args+14 - integer,parameter:: pr_node_size=15 + integer,parameter:: pr_when= cnode_args+15 + integer,parameter:: pr_whenvar= cnode_args+16 + integer,parameter:: pr_node_size=17 ! Offsets into builtin nodes only integer,parameter:: bi_opcode=cnode_args+7 @@ -466,8 +468,6 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) write(iunit,'(a)') ' [dcomm]' if(cnode_flags_set(cnode,cnode_args+2,proc_is_file)) & write(iunit,'(a)') ' [file]' - if(cnode_flags_set(cnode,cnode_args+2,proc_needs_par)) & - write(iunit,'(a)') ' [needs par]' call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& sig_cache,cnode_arg(cnode,1)) write(iunit,'(a)') '}' @@ -480,24 +480,16 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) write(iunit,'(a)') '}' case(cnode_is_arglist) write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'{' - if(cnode_flags_set(cnode,cnode_args+1,proc_is_var)) then - do i=5,cnode_numargs(cnode),2 - write(iunit,'(a)') trim(pm_name_as_string(context,& - cnode_get_name(cnode,cnode_args+i-1)))//' --> ['//& - trim(pm_int_as_string(cnode_get_num(cnode,cnode_args+i)))//']' - enddo - else - do i=3,cnode_numargs(cnode),2 - write(iunit,'(a)') ' '//& - trim(pm_name_as_string(context,& - key%data%i(key%offset+pm_fast_esize(key))))//& - trim(pm_type_as_string(context,& - cnode_num_arg(cnode,i)))//' {' - call print_proc_cnode(context,iunit,pm_null_obj,& - sig_cache,cnode_arg(cnode,i+1)) - write(iunit,'(a)') ' }' - enddo - endif + do i=3,cnode_numargs(cnode),2 + write(iunit,'(a)') ' '//& + trim(pm_name_as_string(context,& + key%data%i(key%offset+pm_fast_esize(key))))//& + trim(pm_type_as_string(context,& + cnode_num_arg(cnode,i)))//' {' + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode_arg(cnode,i+1)) + write(iunit,'(a)') ' }' + enddo write(iunit,'(a)') '}' case(cnode_is_any_sig) write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Any{' @@ -535,6 +527,8 @@ subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) write(iunit,'(a)') ' '//& trim(pm_name_as_string(context,cnode_get_num(cnode,pr_name)))//& + merge('.',merge(merge('''','%',cnode_flags_set(cnode,pr_flags,proccall_is_general)),' ',& + cnode_flags_set(cnode,pr_flags,proccall_is_comm)),cnode_flags_set(cnode,pr_flags,proccall_is_ref))//& trim(pm_type_as_string(context,cnode_get_num(cnode,pr_ptype)))//' {' if(cnode_get_kind(cnode)==cnode_is_builtin) then @@ -542,23 +536,10 @@ subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) op_names(cnode_get_num(cnode,bi_opcode))//& pm_int_as_string(cnode_get_num(cnode,bi_opcode2)) else - write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & ' [nargs=',& cnode_get_num(cnode,pr_nargs),',nret=',cnode_get_num(cnode,pr_nret),& ',ncalls=',cnode_get_num(cnode,pr_ncalls),']' - if(cnode_flags_set(cnode,pr_flags,proc_is_comm)) & - write(iunit,'(a)') ' [loop]' - if(cnode_flags_set(cnode,pr_flags,proc_is_each_proc)) & - write(iunit,'(a)') ' [each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_dup_each)) & - write(iunit,'(a)') ' [dup-each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_thru_each)) & - write(iunit,'(a)') ' [thru-each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_empty_each)) & - write(iunit,'(a)') ' [empty-each]' - flags=cnode_get_kind(cnode) - !write(*,*) 'Kind=',flags call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,pr_cblock),4) endif @@ -600,7 +581,11 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) endif endif elseif(signo==0) then - call append_to_line(iunit,str,i,' VAR-CALL ',.false.,depth) + str=repeat(' ',depth)//'var-call' + i=len_trim(str)+1 + call print_value_cnode(context,iunit,rvec,sig_cache,& + cnode_get(cnode,call_var),depth,str,i) + call append_to_line(iunit,str,i,': ',.false.,depth) else p=pm_dict_key(context,sig_cache,& int(signo,pm_ln)) @@ -653,9 +638,14 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) k=0 do j=nret+1,nargs if(.not.pm_fast_isnull(amps)) then - if(amps%data%i(amps%offset+k)==i-nret) then - call append_to_line(iunit,str,i,'&',.false.,depth) - k=min(k+1,pm_fast_esize(amps)) + if(pm_fast_vkind(amps)/=pm_int) then + call append_to_line(iunit,str,i,'?AMPS?',.false.,depth) + exit + else + if(amps%data%i(amps%offset+k)==i-nret) then + call append_to_line(iunit,str,i,'&',.false.,depth) + k=min(k+1,pm_fast_esize(amps)) + endif endif endif call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) @@ -682,6 +672,7 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) contains include 'fesize.inc' include 'fisnull.inc' + include 'fvkind.inc' end subroutine print_call_cnode recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) @@ -769,10 +760,16 @@ subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) integer,intent(in):: flags logical,intent(in):: proc_flags integer,intent(in):: depth - if(iand(flags,call_is_comm)/=0) then - call append_to_line(iunit,str,i,'%',.false.,depth) + if(iand(flags,proccall_is_comm)/=0) then + if(iand(flags,proccall_is_general)/=0) then + call append_to_line(iunit,str,i,'''',.false.,depth) + elseif(iand(flags,proccall_is_ref)/=0) then + call append_to_line(iunit,str,i,'.',.false.,depth) + else + call append_to_line(iunit,str,i,'%',.false.,depth) + endif endif - if(flags/=iand(flags,call_is_comm)) then + if(flags/=iand(flags,proccall_is_comm)) then call append_to_line(iunit,str,i,'<',.false.,depth) if(iand(flags,proc_run_complete)/=0) then call append_to_line(iunit,str,i,'C',.false.,depth) @@ -786,19 +783,16 @@ subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) if(iand(flags,proc_run_always)/=0) then call append_to_line(iunit,str,i,'A',.false.,depth) endif - if(iand(flags,proc_inline)/=0) then + if(iand(flags,proccall_is_inline)/=0) then call append_to_line(iunit,str,i,'I',.false.,depth) endif - if(iand(flags,proc_no_inline)/=0) then + if(iand(flags,proccall_is_no_inline)/=0) then call append_to_line(iunit,str,i,'N',.false.,depth) endif if(proc_flags) then if(iand(flags,proc_is_open)/=0) then call append_to_line(iunit,str,i,'o',.false.,depth) endif - if(iand(flags,proc_is_each_proc)/=0) then - call append_to_line(iunit,str,i,'e',.false.,depth) - endif if(iand(flags,proc_is_cond)/=0) then call append_to_line(iunit,str,i,'c',.false.,depth) endif diff --git a/src/codegen.f90 b/src/codegen.f90 index 0f06153..662fa85 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -58,9 +58,6 @@ module pm_codegen logical,parameter:: debug_codegen=.false. logical,parameter:: debug_more_codegen=.false. - - ! Langauge features - integer,parameter:: num_comm_args=3 ! Limits integer,parameter:: max_code_stack=4096 @@ -69,10 +66,6 @@ module pm_codegen integer,parameter:: max_type_nesting=64 integer,parameter:: max_error_nodes=1024 - ! Parallel status of a value - integer,parameter:: value_is_shared=0 - integer,parameter:: value_is_private=1 - ! Flags indicating state within parallel statement nesting integer,parameter:: par_state_nhd=0 integer,parameter:: par_state_outer=1 @@ -155,6 +148,9 @@ module pm_codegen integer:: par_depth,proc_par_depth integer:: par_base,over_base + ! State variables (as position in coder%var) + integer:: state_base,mask + ! Caches for call signatures and resolved procedures type(pm_ptr):: sig_cache,proc_cache,poly_cache @@ -166,7 +162,7 @@ module pm_codegen type(pm_ptr):: proc_name_vals ! Misc values - type(pm_ptr):: temp,temp2,true,false,one,comm_amp,check_mess,undef_val + type(pm_ptr):: temp,temp2,true,false,one,comm_amp,std_amp,check_mess,undef_val ! 'true and 'false types integer:: true_fix,false_fix,true_literal,false_literal @@ -184,15 +180,21 @@ module pm_codegen ! This point in a subscript tuple integer:: subs_index - ! Counter to give each proc a unique index + ! Counter to give each proc a unique index for all procs integer:: id ! Counter to provide unique index for all nodes created integer:: index + ! Counter to provide unique index for all blocks + integer:: block_id + ! Nesting depth of if statements (offset into vstack) integer:: lex_scope + ! Blocks + integer:: block_entry,block_base + ! Flags indicating type inference not complete logical:: types_finished,redo_calls,incomplete,first_pass @@ -213,7 +215,6 @@ module pm_codegen integer,dimension(max_par_depth)::trace_keys integer:: trace_depth - ! Error count type(pm_ptr):: error_nodes(max_error_nodes) integer:: num_errors @@ -247,7 +248,7 @@ subroutine init_coder(context,coder,visibility) coder%undef_val,& array=coder%var,array_size=coder%top) coder%reg2=>pm_register(context,'coder-node stack',& - coder%proc_name_vals,coder%poly_cache,coder%comm_amp,array=& + coder%proc_name_vals,coder%poly_cache,coder%comm_amp,coder%std_amp,array=& coder%vstack,array_size=coder%vtop) coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check,& coder%check_mess) @@ -261,7 +262,7 @@ subroutine init_coder(context,coder,visibility) coder%par_depth=0 coder%proc_par_depth=0 coder%par_state=par_state_outer - coder%run_mode=sym_complete + coder%run_mode=sym_private coder%run_flags=0 coder%loop_cblock=pm_null_obj coder%proc_keys=pm_null_obj @@ -280,14 +281,19 @@ subroutine init_coder(context,coder,visibility) coder%one%data%i(coder%one%offset)=1 coder%comm_amp=pm_new_small(context,pm_int,1_pm_p) coder%comm_amp%data%i(coder%comm_amp%offset)=num_comm_args+1 + coder%std_amp=pm_new_small(context,pm_int,1_pm_p) + coder%std_amp%data%i(coder%std_amp%offset)=2 coder%one=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%one)) coder%comm_amp=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%comm_amp)) + coder%std_amp=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%std_amp)) coder%check_mess=pm_new_string(coder%context,'Failed "check" or "test""') coder%proc_name_vals=pm_dict_new(coder%context,8_pm_ln) coder%id=0 + coder%block_id=0 coder%true_fix=pm_new_fix_type(coder%context,coder%true) coder%false_fix=pm_new_fix_type(coder%context,coder%false) coder%true_literal=pm_new_literal_type(coder%context,coder%true) @@ -331,6 +337,7 @@ subroutine trav_prog(coder,stmt_list) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: stmt_list type(pm_ptr):: prog_cblock + integer:: i prog_cblock=make_cblock(coder,pm_null_obj,stmt_list,sym_do) coder%prog_cblock=prog_cblock @@ -340,6 +347,9 @@ subroutine trav_prog(coder,stmt_list) pm_fast_tinyint(coder%context,-9999),int(pm_tiny_int)) coder%undef_val=pop_code(coder) + ! State variables (set to null) + call make_state_vars(coder,prog_cblock,stmt_list) + ! filesystem variable call make_sys_var(coder,prog_cblock,stmt_list,sym_filesystem,var_is_var) call make_sys_call(coder,prog_cblock,stmt_list,sym_get_filesystem,0,1) @@ -365,7 +375,29 @@ subroutine trav_prog(coder,stmt_list) include 'ftiny.inc' end subroutine trav_prog - + !=============================================== + ! Create state variables and set to null + !=============================================== + subroutine make_state_vars(coder,cblock,node,topo) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + type(pm_ptr),intent(in),optional:: topo + coder%state_base=coder%top + if(present(topo)) then + call push_var(coder,sym_topology,topo) + else + call make_sys_var(coder,cblock,node,sym_topology,0) + endif + call make_sys_var(coder,cblock,node,sym_outer,0) + call make_sys_var(coder,cblock,node,sym_region,0) + call make_sys_var(coder,cblock,node,sym_subregion,0) + call make_sys_var(coder,cblock,node,sym_here_in_tile,0) + call make_sys_var(coder,cblock,node,sym_mask,0) + coder%mask=coder%top + call make_sp_call(coder,cblock,node,sym_null,0,& + num_comm_args-merge(1,0,present(topo))) + end subroutine make_state_vars + !******************************************************* ! SEQUENTIAL STATEMENTS !******************************************************* @@ -487,47 +519,54 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& case(sym_while,sym_while_invar) save_par_state=coder%par_state lex_scope=push_lex_scope(coder) - call make_const(coder,cblock,node,node_arg(node,1)) cblock2=make_cblock(coder,cblock,node,sym_while) - call trav_xexpr(coder,cblock2,node,node_arg(node,2)) + call trav_xexpr(coder,cblock2,node,node_arg(node,1)) if(sym==sym_while_invar) then call code_check_invar(coder,cblock2,node,top_code(coder)) endif call close_cblock(coder,cblock2) coder%par_state=save_par_state -!!$ coder%par_state=par_state_for_loop(coder,node,coder%par_state,& -!!$ node_get_num(node,node_args)/=0,sym==sym_while_invar) coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& - node_arg(node,3),sym_while) + node_arg(node,2),sym_while) call get_lex_scope(coder,node) - call make_sp_call(coder,cblock,node,sym_while,5,0) + call make_sp_call(coder,cblock,node,sym_while,4,0) call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_until,sym_until_invar) lex_scope=push_lex_scope(coder) - call make_const(coder,cblock,node,node_arg(node,1)) save_par_state=coder%par_state -!!$ coder%par_state=par_state_for_loop(coder,node,coder%par_state,& -!!$ node_get_num(node,node_args)/=0,sym==sym_until_invar) cblock2=make_cblock(coder,cblock,node,sym_until) coder%lex_scope=lex_scope call trav_open_stmt_list(coder,cblock2,node,& - node_arg(node,3)) + node_arg(node,2)) iscomm=cnode_flags_set(top_code(coder),cblock_flags,cblock_is_comm) - call trav_xexpr(coder,cblock2,node,node_arg(node,2)) + call trav_xexpr(coder,cblock2,node,node_arg(node,1)) if(sym==sym_until_invar) then call code_check_invar(coder,cblock2,node,top_code(coder)) endif call close_cblock(coder,cblock2) + do j=coder%vtop-1,coder%vtop + write(*,*) '++++++++++++++++',j + call qdump_code_tree(coder,pm_null_obj,6,coder%vstack(j),2) + enddo + write(*,*) '+++++++++++++++++++++' call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,& - sym_until,4,0) + sym_until,3,0) call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_do_stmt) - call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) - call make_sp_call(coder,cblock,node,sym_do,1,0) + if(node_numargs(node)==1) then + call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) + call make_sp_call(coder,cblock,node,sym_do,1,0) + else + call make_block_proc(coder,cblock,node,& + node_arg(node,1),node_num_arg(node,2),& + pm_null_obj,0,& + node_arg(node,4)) + call trav_call(coder,cblock,node,node_arg(node,3),0,.true.) + endif case(sym_proceed) continue case(sym_mode) @@ -575,7 +614,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call hide_vars(coder,base+1,j) case(sym_over) ! call trav_over_stmt(coder,cblock,list,node) - case(sym_define) + case(sym_assign) call trav_assign_define(coder,cblock,list,node) case(sym_assign_list) call trav_assign_define_list(coder,cblock,list,node) @@ -618,6 +657,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& ! call trav_par_stmt(coder,cblock,list,node) case(sym_any,sym_any_invar) call trav_any_stmt(coder,cblock,list,node,sym) + case(sym_yield) + p=node_arg(node,1) + call trav_call(coder,cblock,node,p,0,.true.) case(sym_ddollar) n=node_num_arg(node,1) select case(n) @@ -750,7 +792,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& endif !call dump_parse_tree(coder%context,6,listp,2) call code_error(coder,list,'Err::') - call pm_dump_tree(coder%context,6,node,2) + !call pm_dump_tree(coder%context,6,node,2) call pm_panic('Unknown node sym in trav_stmt_list') end select if(coder%vtop/=vbase) then @@ -818,6 +860,29 @@ subroutine pop_lex_scope(coder) call drop_code(coder) end subroutine pop_lex_scope + !========================================== + ! Record read or write (if modify is true) + ! access to a variable + !=========================================== + subroutine access_var(coder,var,modify) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(inout):: var + logical,intent(in):: modify + if(coder%block_base>0) write(*,*) 'access var',modify,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))),& + cnode_get_num(var,var_index) + if(modify) then + call cnode_set_flags(var,var_flags,var_is_changed) + else + if(cnode_flags_set(var,var_flags,var_is_accessed)) then + call cnode_set_flags(var,var_flags,var_is_multi_access) + else + call cnode_set_flags(var,var_flags,var_is_accessed) + endif + endif + call update_change_lists(coder,var,modify) + end subroutine access_var + !============================================= ! Add var to the change list for all if scopes ! that are nested inside the scope in which @@ -827,9 +892,10 @@ subroutine update_change_lists(coder,var,modify) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: var logical,intent(in):: modify - integer:: lex_scope + integer:: lex_scope,lex_scope_of_var lex_scope=coder%lex_scope - do while(cnode_get_num(var,var_lex_scope)',coder%wtop,coder%vtop + + nargs=node_numargs(namelist) + varargs=node_sym(namelist)==sym_dotdotdot + flags=proccall_is_comm+proccall_is_general + + ! Parameter type + call push_word(coder,merge(pm_type_new_vtuple,pm_type_new_tuple,varargs)) + call push_word(coder,amps) + do i=1,nargs+8 + call push_word(coder,0) + enddo + call make_type(coder,nargs+10) + partype=pop_word(coder) + + ! Result type + call push_word(coder,pm_type_is_undef_result) + call push_word(coder,nret) + call make_type(coder,2) + restype=pop_word(coder) + + ! Create block proc name + coder%block_id=coder%block_id+1 + namestr='PM__block'//trim(pm_int_as_string(coder%block_id)) + name=pm_name2(coder%context,sym_block,pm_name_entry(coder%context,namestr)) + + write(*,*) 'REGAIN--->',coder%wtop,coder%vtop + + call make_sys_var(coder,cblock,stmt,sym_block_proc_a,var_is_shadowed) + + ! Create proc object + call code_num(coder,partype) + call code_num(coder,restype) + call code_num(coder,nargs) + call code_num(coder,nret) + call code_num(coder,flags) + call code_num(coder,amps) + call code_num(coder,name) + cblock2=make_cblock(coder,cblock,stmtlist,sym_do_stmt) + call code_num(coder,0) + call code_num(coder,0) + coder%id=coder%id+1 + call code_num(coder,coder%id) + call code_num(coder,0) + call code_null(coder) + call code_null(coder) + call code_null(coder) + call code_null(coder) + call code_null(coder) + call make_code(coder,stmt,cnode_is_proc,pr_node_size) + proc=top_code(coder) + + write(*,*) 'AGAIN--->',coder%wtop,coder%vtop + + ! Create one-element signature + call make_code(coder,stmt,cnode_is_callsig,1) + + args(1)=name + signo=pm_idict_add(coder%context,coder%sig_cache,& + args,1,pop_code(coder)) + + ! Create procedure value type + call push_word(coder,pm_type_new_proc) + call push_word(coder,name) + call push_word(coder,pm_type_new_proc_sig) + call push_word(coder,sym_dash) + call push_word(coder,partype) + call push_word(coder,restype) + call make_type(coder,4) + call make_type(coder,3) + + write(*,*) 'proctyp=',trim(pm_type_as_string(coder%context,top_word(coder))) + + call make_const(coder,cblock,stmt,& + pm_fast_name(coder%context,name),pop_word(coder)) + call make_sys_call(coder,cblock,stmt,sym_dup,1,1) + + + save_index=coder%index + save_ncalls=coder%proc_ncalls + coder%index=0 + coder%proc_ncalls=0 + + call push_block_scope(coder,cblock2) + + write(*,*) 'MARZ' + do i=1,coder%top + write(*,*) pm_name_as_string(coder%context,coder%stack(i)) + enddo + write(*,*) '---end---' + + base=coder%top + + ! Create state variable parameters + call make_sys_var(coder,cblock2,stmt,sym_topology,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,stmt,sym_outer,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,stmt,sym_region,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,stmt,sym_subregion,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,stmt,sym_here_in_tile,& + var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,stmt,sym_mask,var_is_param+var_is_shadowed) + + ! Create variables for block imports and exports + call make_sys_var(coder,cblock2,stmt,& + sym_block_inouts,var_is_param+var_is_ref+var_is_var) + call make_sys_var(coder,cblock2,stmt,& + sym_block_ins,var_is_param) + + ! Remaining parameter variables + call trav_params(coder,cblock2,namelist,amps,1,8) + + write(*,*) 'THEN--->',coder%wtop,coder%vtop + + cblock3=make_cblock(coder,cblock2,stmtlist,sym_do_stmt) + coder%lex_scope=coder%lex_scope+1 + + + call trav_open_stmt_list(coder,cblock3,stmt,stmtlist) + + call trav_xexpr(coder,cblock3,stmt,rtns) + coder%lex_scope=coder%lex_scope-1 + call close_cblock(coder,cblock3) + + write(*,*) 'CARZ' + do i=1,coder%top + write(*,*) pm_name_as_string(coder%context,coder%stack(i)) + enddo + write(*,*) '---end---' + + call extract_block_vars(coder,cblock2,stmt,coder%var(base+7),.true.) + call extract_block_vars(coder,cblock2,stmt,coder%var(base+8),.false.) + call make_sp_call(coder,cblock2,stmt,sym_do,1,0) + + call cnode_set_num(proc,pr_max_index,coder%index) + call cnode_set_num(proc,pr_ncalls,coder%proc_ncalls) + coder%index=save_index + coder%proc_ncalls=save_ncalls + + write(*,*) 'AFTA--->',coder%wtop,coder%vtop + call close_cblock(coder,cblock2) + + write(*,*) 'VARZ' + do i=1,coder%top + write(*,*) pm_name_as_string(coder%context,coder%stack(i)) + enddo + write(*,*) '---end---' + + call pop_block_scope(coder,cblock,stmt) + + + + write(*,*) 'FINALLY--->',coder%wtop,coder%vtop + + contains + include 'fisnull.inc' + include 'fname.inc' + end subroutine make_block_proc + + subroutine extract_block_vars(coder,cblock,node,avar,access) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,avar + logical,intent(in):: access + + type(pm_ptr):: p,var + integer:: index,i + + index=coder%wstack(coder%block_entry+3) + p=coder%vstack(index) + i=1 + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + if(iand(cnode_get_num(var,var_flags),var_is_changed)/=0.eqv.access) then + call extract_var(coder,cblock,node,coder%var(index),avar,i) + i=i+1 + endif + p=p%data%ptr(p%offset+1) + enddo + contains + include 'fisnull.inc' + end subroutine extract_block_vars + + subroutine push_block_vars(coder,list,access,n) + type(code_state),intent(inout):: coder + logical,intent(in):: access + type(pm_ptr),intent(in):: list + integer,intent(out):: n + + type(pm_ptr):: p,var + integer:: index,i + + p=list + i=0 + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + if(iand(cnode_get_num(var,var_flags),var_is_changed)/=0.eqv.access) then + call code_val(coder,var) + i=i+1 + endif + p=p%data%ptr(p%offset+1) + enddo + n=i + contains + include 'fisnull.inc' + end subroutine push_block_vars + subroutine extract_var(coder,cblock,node,var,avar,index) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,var,avar + integer,intent(in):: index + + call code_val(coder,var) + call code_val(coder,avar) + call make_long_const(coder,cblock,node,int(index,pm_ln)) + call make_comm_sys_call(coder,cblock,node,sym_elem_at_index,2,1,& + aflags=proccall_is_ref,assign=.true.) + end subroutine extract_var + + subroutine push_block_scope(coder,cblock) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock + integer:: base + base=coder%wtop+1 + call push_word(coder,coder%block_entry) + call push_word(coder,coder%top) + call push_word(coder,coder%lex_scope+1) + call code_null(coder) + call push_word(coder,coder%vtop) + call code_val(coder,cblock) + coder%block_base=coder%top + coder%block_entry=base + end subroutine push_block_scope + + subroutine pop_block_scope(coder,cblock,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + type(pm_ptr):: list + type(pm_ptr)::p,var + integer:: index,nwrites,nreads + if(pm_debug_checks) then + if(coder%wtop/=coder%block_entry+3) then + call pm_panic("pop_block_scope: wstack") + endif + if(coder%vtop-1/=coder%wstack(coder%block_entry+3)) then + call pm_panic("pop_block_scope: vstack") + endif + endif + list=coder%vstack(coder%vtop-1) + coder%temp2=list + coder%block_entry=coder%wstack(coder%block_entry) + coder%block_base=coder%wstack(coder%block_entry+1) + coder%vtop=coder%vtop-2 + coder%wtop=coder%wtop-4 + p=list + nwrites=0 + call make_sys_var(coder,cblock,node,sym_block_inouts_a,& + var_is_shadowed+var_is_var+var_is_ref) + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + if(cnode_flags_set(var,var_flags,var_is_changed)) then + call code_val(coder,cnode_get(var,var_extra_info)) + nwrites=nwrites+1 + endif + p=p%data%ptr(p%offset+1) + enddo + if(nwrites>0) then + call make_sp_call(coder,cblock,node,sym_open_smiley,nwrites,1) + else + call make_sp_call(coder,cblock,node,sym_null,0,1) + endif + p=list + nreads=0 + call make_sys_var(coder,cblock,node,sym_block_ins_a,var_is_shadowed) + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + write(*,*) 'REAd',& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) + if(cnode_flags_clear(var,var_flags,var_is_changed)) then + var=cnode_get(coder%var(index),var_extra_info) + call code_val(coder,var) + nreads=nreads+1 + else + var=cnode_get(coder%var(index),var_extra_info) + endif + coder%var(index)=var + p=p%data%ptr(p%offset+1) + enddo + if(nreads>0) then + call make_sp_call(coder,cblock,node,sym_open_smiley,nreads,1) + else + call make_sp_call(coder,cblock,node,sym_null,0,1) + endif + coder%temp2=pm_null_obj + contains + include 'fisnull.inc' + end subroutine pop_block_scope + + recursive subroutine import_to_block_scope(coder,index,var,block_entry) + type(code_state),intent(inout):: coder + integer,intent(in):: index,block_entry + type(pm_ptr),intent(inout):: var + integer:: var_scope,block_scope,block_links + write(*,*) 'import_to_block_scope',block_entry,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) + if(block_entry==0) return + var_scope=cnode_get_num(var,var_lex_scope) + block_scope=coder%wstack(block_entry+2) + block_links=coder%wstack(block_entry+3) + write(*,*) 'with',var_scope,block_scope,block_entry + if(var_scope>=block_scope) return + write(*,*) 'recursing with',coder%wstack(block_entry) + call import_to_block_scope(coder,index,var,coder%wstack(block_entry)) + call make_var(coder,& + coder%vstack(block_links+1),& + pm_null_obj,& + cnode_get(var,var_name),& + ior(cnode_get_num(var,var_flags),var_is_imported),& + extra_info=var) + var=pop_code(coder) + call cnode_set_num(var,var_lex_scope,coder%wstack(block_entry+2)) + write(*,*) 'lex scope now',coder%wstack(block_entry+2) + write(*,*) 'index now',cnode_get_num(var,var_index) + call add_to_change_list(coder,coder%vstack(block_links),& + pm_fast_tinyint(coder%context,index)) + write(*,*) 'pushing block var',index + call qdump_code_tree(coder,pm_null_obj,6,var,2) + coder%var(index)=var + contains + include 'fisnull.inc' + include 'ftiny.inc' + end subroutine import_to_block_scope + + !============================================================== ! Traverse extended expression: expr [check expr] { where ...} !============================================================== @@ -925,7 +1341,7 @@ subroutine apply_x(nodep,node) wbase=coder%wtop if(pm_fast_isnull(node)) return select case(node_sym(node)) - case(sym_define) + case(sym_assign) call trav_assign_define(coder,cblock,nodep,node) case(sym_case) do i=1,node_numargs(node) @@ -1082,33 +1498,33 @@ recursive subroutine trav_mode_stmt(coder,cblock,node,nsym,isexpr) integer,intent(in):: nsym logical,intent(in):: isexpr integer:: sym,save_run_mode,save_run_flags,save_par_state - sym=node_num_arg(node,2) - if(coder%par_state==par_state_outer) then - call code_error(coder,node,'Cannot have "'//& - trim(sym_names(sym))//& - '" statement outside of a parallel context') - elseif(coder%par_state==par_state_nhd) then - call code_error(coder,node,'Cannot have "'//& - trim(sym_names(sym))//& - '" statement in main body of "nhd" statement') - endif - - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - coder%run_mode=sym - select case(sym) - case(sym_coherent:sym_mirrored) - coder%run_flags=proc_run_complete+proc_run_always - case(sym_shared) - coder%run_flags=proc_run_shared+proc_run_always - end select - if(isexpr) then - call trav_expr(coder,cblock,node,node_arg(node,1)) - else - call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) - endif - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags +!!$ sym=node_num_arg(node,2) +!!$ if(coder%par_state==par_state_outer) then +!!$ call code_error(coder,node,'Cannot have "'//& +!!$ trim(sym_names(sym))//& +!!$ '" statement outside of a parallel context') +!!$ elseif(coder%par_state==par_state_nhd) then +!!$ call code_error(coder,node,'Cannot have "'//& +!!$ trim(sym_names(sym))//& +!!$ '" statement in main body of "nhd" statement') +!!$ endif +!!$ +!!$ save_run_mode=coder%run_mode +!!$ save_run_flags=coder%run_flags +!!$ coder%run_mode=sym +!!$ select case(sym) +!!$ case(sym_coherent:sym_invar) +!!$ coder%run_flags=proc_run_complete+proc_run_always +!!$ case(sym_shared) +!!$ coder%run_flags=proc_run_shared+proc_run_always +!!$ end select +!!$ if(isexpr) then +!!$ call trav_expr(coder,cblock,node,node_arg(node,1)) +!!$ else +!!$ call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) +!!$ endif +!!$ coder%run_mode=save_run_mode +!!$ coder%run_flags=save_run_flags end subroutine trav_mode_stmt !======================================================== @@ -1395,7 +1811,7 @@ function call_start(coder,cblock,list,invar) result(iter) if(invar) then do i=coder%top-2,coder%top call code_val(coder,coder%var(i)) - call code_num(coder,sym_mirrored) + call code_num(coder,sym_invar) call make_basic_sp_call(coder,cblock,list,sym_set_mode,2,0,coder%par_depth) enddo if(pm_is_compiling) then @@ -1666,7 +2082,7 @@ recursive subroutine trav_assign_define(coder,cblock,pnode,node) rhs=node_arg(node,2) sym=node_sym(lhs) n=node_numargs(lhs) - if(sym/=sym_define) n=n-1 + if(sym/=sym_assign) n=n-1 call trav_rhs(coder,cblock,node,rhs,n) call trav_lhs(coder,cblock,node,lhs,rhs) coder%vtop=base @@ -1686,7 +2102,7 @@ recursive subroutine trav_assign_define_list(coder,cblock,pnode,node) lhs=node_arg(assn,1) sym=node_sym(lhs) n=node_numargs(lhs) - if(sym/=sym_define) n=n-1 + if(sym/=sym_assign) n=n-1 rhs=node_arg(assn,2) call trav_rhs(coder,cblock,node,rhs,n) enddo @@ -1718,8 +2134,8 @@ subroutine trav_lhs(coder,cblock,node,lhs,rhs) call make_definition(coder,cblock,lhs,node_arg(lhs,i),& merge(0,var_is_var,sym==sym_const)) enddo - case(sym_define) - if(node_sym(rhs)==sym_define) then + case(sym_assign) + if(node_sym(rhs)==sym_assign) then rhs_val=node_arg(rhs,1) else rhs_val=rhs @@ -1778,7 +2194,7 @@ subroutine trav_rhs(coder,cblock,node,rhs,n) integer:: i,rsym,base rsym=node_sym(rhs) base=coder%vtop - if(rsym==sym_define) then + if(rsym==sym_assign) then call trav_top_expr(coder,cblock,node,node_arg(rhs,1)) do i=2,n call dup_expr(coder,top_code(coder)) @@ -1908,7 +2324,7 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) else sym=node_sym(node) select case(sym) - case(sym_sub,sym_dot_sub,sym_dot,sym_get_dot,sym_at,sym_damp) + case(sym_sub,sym_dot_sub,sym_dot,sym_get_dot,sym_at,sym_pling,sym_open_smiley) outmode=trav_ref(coder,cblock,pnode,node,0) call assign_call(node,outer,.false.,.false.,iand(outmode,ref_has_at)/=0) case(sym_name) @@ -2102,8 +2518,7 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,mode,avar) call code_error(coder,pnode,& 'Cannot assign to constant: ',name) else - call cnode_set_flags(var,var_flags,var_is_changed) - call update_change_lists(coder,var,.true.) + call access_var(coder,var,.true.) endif endif if(iand(mode,ref_is_val)/=0) then @@ -2219,21 +2634,23 @@ recursive function trav_ref(coder,cblock,pnode,node,mode) result(outmode) call trav_expr(coder,cblock,node,node_arg(node,2)) call make_basic_sp_call(coder,cblock,node,& sym_get_dot_ref,2,1,coder%par_depth) - case(sym_damp) + case(sym_open_smiley) + call make_temp_var(coder,cblock,node) + call dup_code(coder) do i=1,node_numargs(node) outmode=trav_ref(coder,cblock,node,node_arg(node,i),mode) enddo - call make_sys_call_rtn(coder,cblock,node,sym_list,node_numargs(node),1) + call make_sp_call(coder,cblock,node,sym_open_smiley,node_numargs(node),1) case(sym_caret) save_run_flags=coder%run_flags coder%run_flags=ior(coder%run_flags,call_inline_when_compiling) call trav_expr(coder,cblock,pnode,node_arg(node,1)) coder%run_flags=save_run_flags outmode=0 - case(sym_at) + case(sym_pling) if(iand(mode,ref_is_val+ref_ignores_rules)==0.and..not.coder%in_sync) then call code_error(coder,node,& - 'Cannot change value of "@" expression outside of a "sync" statement') + 'Cannot change value of "!" expression outside of a "sync" statement') endif call check_par_context(coder,cblock,node,.false.) outmode=ior(trav_ref(coder,cblock,node,node_arg(node,1),mode),& @@ -2247,6 +2664,11 @@ recursive function trav_ref(coder,cblock,pnode,node,mode) result(outmode) case(sym_name) call trav_ref_to_var(coder,cblock,node,node_arg(node,1),mode) outmode=0 + case(sym_dot_call) + outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) + call trav_exprlist(coder,cblock,node,node_arg(node,3)) + call make_comm_sys_call_rtn(coder,cblock,node,node_num_arg(node,2),& + node_numargs(node_arg(node,3))+1,1,aflags=proccall_is_ref,assign=.true.) case default if(iand(mode,ref_is_val)==0) then call code_error(coder,pnode,& @@ -2277,6 +2699,8 @@ end function trav_ref ! (or increment existing tiny int value) ! if argument #i definitely does not alias argument #j !========================================================== + + ! BROKEN _ Does bad things to vstack (probably called with wrong argbase) subroutine trav_alias_checks(coder,cblock,list,amp,j,argbase) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,list,amp @@ -2284,6 +2708,7 @@ subroutine trav_alias_checks(coder,cblock,list,amp,j,argbase) integer:: i,k,base1,base2 logical:: finished type(pm_ptr):: p,name,name2,var + return p=node_arg(list,j) p=node_arg(p,1) base1=coder%vtop @@ -2357,7 +2782,7 @@ recursive function get_ref_pattern(coder,node,name) result(finished) case(sym_dot) finished=get_ref_pattern(coder,node_arg(node,1),name) if(.not.finished) call code_val(coder,node_arg(node,2)) - case(sym_at) + case(sym_at,sym_pling) finished=get_ref_pattern(coder,node_arg(node,1),name) finished=.true. case(sym_name) @@ -2631,6 +3056,7 @@ subroutine define_sys_var(coder,cblock,node,name,flags) integer,intent(in):: flags integer:: junk type(pm_ptr):: var + write(*,*) '>>>',pm_name_as_string(coder%context,name) call make_sys_var(coder,cblock,node,name,flags) var=top_code(coder) call swap_code(coder) @@ -2663,8 +3089,7 @@ subroutine make_var_mode(coder,cblock,node,var) if(coder%run_flags==0) then if(iand(cnode_get_num(var,var_flags),var_is_var)/=0) then call code_val(coder,var) - call make_basic_sp_call(coder,cblock,node,& - merge(sym_partial,sym_coherent,coder%par_state>=par_state_cond),& + call make_basic_sp_call(coder,cblock,node,sym_private,& 1,0,coder%par_depth) endif else @@ -2703,8 +3128,7 @@ subroutine make_var_assignment(coder,cblock,node,var,aflags) else call make_assign_call(coder,cblock,node,sym_assignment,2,0,aflags=flags) endif - call cnode_set_flags(v,var_flags,var_is_changed) - call update_change_lists(coder,var,.true.) + call access_var(coder,v,.true.) end subroutine make_var_assignment @@ -2786,7 +3210,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) endif case(sym_null) call make_const(coder,cblock,pnode,pm_null_obj,int(pm_null)) - case(sym_arg,sym_name,sym_use) + case(sym_dotdotdot,sym_name,sym_use) call trav_name(coder,cblock,node,sym,node_arg(node,1)) case(sym_proc) call proc_const(coder,cblock,pnode,node) @@ -2818,16 +3242,6 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) p=node_arg(node,1) call name_const(node,int(p%offset)) return - case(sym_dash) - p=node_arg(node,1) - if(pm_fast_isname(p)) then - call make_static_bool_const(coder,cblock,node,& - p%offset==sym_true) - else - call make_const(coder,cblock,node,p,& - pm_new_fix_type(coder%context,p)) - endif - return case(sym_fix) save_fixed=coder%fixed coder%fixed=.true. @@ -2859,13 +3273,15 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) enddo call make_sys_call_rtn(coder,cblock,node,& sym,node_numargs(node),1) - case(sym_damp) + case(sym_open_smiley) + call make_temp_var(coder,cblock,node) + call dup_code(coder) do i=1,node_numargs(node) call trav_expr(coder,cblock,& node,node_arg(node,i)) enddo - call make_sys_call_rtn(coder,cblock,node,& - sym_list,node_numargs(node),1) + call make_sp_call(coder,cblock,node,& + sym_open_smiley,node_numargs(node),1) case(sym_if_expr) do i=1,node_numargs(node) call trav_expr(coder,cblock,& @@ -2962,7 +3378,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) endif case(sym_get_dot_ref) outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - case(sym_get_dot,sym_sub,sym_dot_sub) + case(sym_get_dot,sym_sub,sym_dot_sub,sym_dot_call) outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) if(coder%par_state>par_state_outer) then p=pop_code(coder) @@ -2973,7 +3389,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) else call make_sys_call_rtn(coder,cblock,node,sym_get_val_ref,1,1) endif - case(sym_at) + case(sym_pling) outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) case(sym_open) call make_temp_var(coder,cblock,node) @@ -3028,7 +3444,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) if(pm_fast_isnull(node_arg(node,1))) then call make_sys_call(coder,cblock,node,sym_active,0,1) call dup_code(coder) - call make_basic_sp_call(coder,cblock,node,sym_coherent,1,0,coder%par_depth) + call make_basic_sp_call(coder,cblock,node,sym_private,1,0,coder%par_depth) else call trav_expr(coder,cblock,node,node_arg(node,1)) call make_sys_call(coder,cblock,node,sym_active,1,1) @@ -3246,7 +3662,7 @@ recursive subroutine trav_structrec(coder,cblock,node) endif enddo p=node_arg(elems,j) - if(node_sym(p)==sym_define) then + if(node_sym(p)==sym_assign) then call trav_closed_expr(coder,cblock,p,node_arg(p,2)) else call code_val(coder,coder%undef_val) @@ -3572,24 +3988,31 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) - case(sym_list,sym_dotdotdot) + case(sym_list,sym_dotdotdot,sym_open_smiley) + if(sym==sym_open_smiley) then + p=node_arg(node,1) + sym=node_sym(p) + i=pm_type_is_list + m=1 + else + p=node + i=0 + m=2 + endif if(sym==sym_dotdotdot) then - call push_word(coder,pm_type_new_vtuple) + call push_word(coder,pm_type_new_vtuple+i) else - call push_word(coder,pm_type_new_tuple) + call push_word(coder,pm_type_new_tuple+i) endif call push_word(coder,0) - base=coder%wtop nshared=0 - n=node_numargs(node) - do i=2,n,2 - val=node_arg(node,i) - if(node_sym(val)==sym_mode) nshared=nshared+1 + n=node_numargs(p) + do i=m,n,m + val=node_arg(p,i) call trav_type(coder,val,val) enddo - coder%wstack(base)=nshared - call make_type(coder,n/2+2) - case(sym_define,sym_var) + call make_type(coder,n/m+2) + case(sym_assign,sym_var) call trav_type(coder,pnode,node_arg(node,1)) case(sym_pm_dref) call push_word(coder,pm_type_is_dref) @@ -3605,7 +4028,7 @@ recursive subroutine trav_type(coder,pnode,node) typno=pop_word(coder) call push_word(coder,& pm_type_add_mode(coder%context,typno,& - node_num_arg(node,2),.false.,.true.)) + node_num_arg(node,2),istype=.true.)) case(sym_result) call push_word(coder,pm_type_new_tuple) call push_word(coder,0) @@ -3668,7 +4091,7 @@ recursive subroutine proc_type endif enddo call push_word(coder,pm_type_new_proc_sig) - call push_word(coder,node_get_num(node,node_args+1)) + call push_word(coder,node_num_arg(node,2)) do i=3,4 list=node_arg(node,i) @@ -4462,11 +4885,11 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) keys=node_arg(node,4) keynames=node_arg(node,5) flags=node_num_arg(node,6) - if(node_sym(list)==sym_dotdotdot) then flags=ior(flags,call_is_vararg) endif nargs=node_numargs(list) + iscomm=iand(flags,proccall_is_comm)/=0 if(debug_codegen) then write(*,*) 'TRAV CALL>',& @@ -4474,8 +4897,6 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) nargs,nret,coder%vtop,flags endif - iscomm=iand(flags,call_is_comm)/=0 - base=coder%vtop has_shared_amp_arg=.false. @@ -4503,6 +4924,8 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) do j=0,pm_fast_esize(amp) i=amp%data%i(amp%offset+j) arg=node_arg(list,i) + + !!! ampbase not set here -- and should be call trav_alias_checks(coder,cblock,list,amp,i,ampbase) nref=nref+1 enddo @@ -4529,7 +4952,7 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif babase=merge(base+3,base+1,iscomm) - call make_arglist(coder,cblock,node,nargs,nret,iscomm) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.) ! Keyword arguments if(.not.pm_fast_isnull(keys)) then @@ -4537,7 +4960,7 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) do i=1,nkeys call trav_expr(coder,cblock,node,node_arg(keys,i)) enddo - call make_arglist(coder,cblock,node,nkeys,0,iscomm) + call make_arglist(coder,cblock,node,nkeys,0,.false.,iscomm) else nkeys=0 call code_null(coder) @@ -4671,92 +5094,6 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) include 'ftiny.inc' end subroutine trav_call - !=========================================================================== - ! Process keyword arguments - returns num of arguments used - ! -- represented as block of arguments between returns and standard args - ! -- Order is determined by signature of *called* procedure(s) - !========================================================================== - recursive function trav_keys(coder,cblock,list,sig,iscomm) result(nkeys) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list,sig - logical,intent(in):: iscomm - integer:: nkeys - integer:: start,i,j - type(pm_ptr):: keys,keynames,empty - keys=cnode_arg(sig,1) - if(.not.pm_fast_isnull(keys)) then - ! Create empty block of arguments - start=coder%vtop - nkeys=pm_set_size(coder%context,keys) - do i=1,nkeys - call code_null(coder) - enddo - else - nkeys=0 - endif - if(.not.pm_fast_isnull(list)) then - if(nkeys==0) then - call code_error(coder,list,& - 'Unexpected keyword arguments') - else - ! Fill in correct entry for each supplied keyword argument - do i=1,node_numargs(list),2 - call trav_expr(coder,cblock,list,node_arg(list,i+1)) - if(iscomm) then - if(var_private(coder,top_code(coder))) then - call code_error(coder,list,& - 'Keyword arguments to communicating call must be shared') - endif - endif - j=pm_set_lookup(coder%context,keys,node_arg(list,i)) - if(j>0) then - coder%vstack(start+j)=pop_code(coder) - else - call code_error(coder,list,& - 'Unexpected keyword argument: ',& - node_arg(list,i)) - call drop_code(coder) - endif - enddo - - ! Process keys... in call - if(node_sym(list)==sym_dotdotdot) then - if(.not.pm_fast_isnull(coder%proc_keys)) then - call pm_set_merge(coder%context,coder%proc_keys,keys) - keynames=pm_set_keys(coder%context,keys) - do i=1,nkeys - if(pm_fast_isnull(coder%vstack(start+i))) then - j=pm_set_lookup(coder%context,coder%proc_keys,& - keynames%data%ptr(keynames%offset+i-1)) - if(j>0) then - call make_temp_var(coder,cblock,list) - coder%vstack(start+i)=top_code(coder) - call make_int_const(coder,cblock,& - list,j) - call make_int_const(coder,cblock,& - list,coder%proc_nret) - call make_sp_call(coder,cblock,& - list,sym_key,2,1) - endif - endif - enddo - endif - endif - endif - endif - if(nkeys>0) then - empty=coder%undef_val - do i=1,nkeys - if(pm_fast_isnull(coder%vstack(start+i))) then - coder%vstack(start+i)=empty - endif - enddo - endif - contains - include 'fisnull.inc' - include 'ftiny.inc' - end function trav_keys - !=============================================================== ! Traverse procedure definition !=============================================================== @@ -4775,7 +5112,8 @@ recursive subroutine trav_proc(coder,node) integer:: save_proc_base,& save_par_base, save_over_base,save_proc_par_depth,& save_proc_nret,save_par_state,save_proc_ncalls,& - save_subs_index,save_lex_scope,save_run_mode,save_run_flags + save_subs_index,save_lex_scope,save_run_mode,save_run_flags,& + save_state_base,save_mask type(pm_ptr):: save_sub_array,save_loop_cblock, & save_proc_keys,save_label logical:: save_aliased,save_in_sync @@ -4787,6 +5125,7 @@ recursive subroutine trav_proc(coder,node) nargs=node_numargs(node_get(node,proc_params))/2 nret=node_get_num(node,proc_numret) + flags=node_get_num(node,proc_flags) !amps=node_get(node,proc_amplocs) !keyargs=pm_null_obj @@ -4803,7 +5142,7 @@ recursive subroutine trav_proc(coder,node) ! Parameter types wbase=coder%wtop obase=coder%vtop - + call code_num(coder,proc_param_type(coder,node)) call code_num(coder,proc_result_type(coder,node)) call code_num(coder,nargs) @@ -4857,18 +5196,18 @@ recursive subroutine trav_proc(coder,node) npars=0 flags=node_get_num(node,proc_flags) pr_flags=flags - if(iand(flags,proc_is_comm)/=0) then + if(iand(flags,proccall_is_comm)/=0) then loop_pars=coder%top - if(iand(flags,proc_run_complete)/=0) then - complete=.true. - call check_param_modes(sym_complete,sym_complete) - elseif(iand(flags,proc_is_uncond)/=0) then - complete=.true. - elseif(iand(flags,proc_is_cond)/=0) then - complete=.false. - else +!!$ if(iand(flags,proc_run_complete)/=0) then +!!$ complete=.true. +!!$ call check_param_modes(sym_complete,sym_complete) +!!$ elseif(iand(flags,proc_is_uncond)/=0) then +!!$ complete=.true. +!!$ elseif(iand(flags,proc_is_cond)/=0) then +!!$ complete=.false. +!!$ else complete=old_complete - endif +!!$ endif call code_params(cblock,.true.,argcall) call code_keys(cblock,tkeys,keycall) call code_loop_startup(cblock,cblock2,cblock3) @@ -4877,14 +5216,9 @@ recursive subroutine trav_proc(coder,node) call code_result(cblock3,flags) call code_loop_finish(cblock,cblock2,cblock3) else - if(iand(flags,proc_run_shared+proc_run_local)/=0) then - loop_pars=coder%top - call check_param_modes(sym_mirrored,sym_shared) - call code_params(cblock,.true.,argcall) - call export_params - else - call code_params(cblock,.false.,argcall) - endif + call code_params(cblock,.false.,argcall) + call make_state_vars(coder,cblock,node,& + topo=coder%var(coder%proc_base+1)) call code_keys(cblock,tkeys,keycall) call code_check(cblock) call code_body(cblock) @@ -4901,6 +5235,14 @@ recursive subroutine trav_proc(coder,node) call code_val(coder,tkeys) ! Keyword arg info call code_val(coder,keycall) ! Keyword call call code_val(coder,argcall) ! Arguments call + if(.not.pm_fast_isnull(node_get(node,proc_when))) then + cblock2=make_cblock(coder,cblock,node,sym_when) + call trav_xexpr(coder,cblock2,node,node_get(node,proc_when)) + call close_cblock(coder,cblock2) + else + call code_null(coder) + call code_null(coder) + endif call make_code(coder,node,cnode_is_proc,pr_node_size) call pm_delete_register(coder%context,reg) @@ -4957,6 +5299,8 @@ subroutine save_proc_state save_run_flags=coder%run_flags save_aliased=coder%aliased save_in_sync=coder%in_sync + save_state_base=coder%state_base + save_mask=coder%mask end subroutine save_proc_state subroutine init_proc_state @@ -4969,7 +5313,7 @@ subroutine init_proc_state coder%proc_par_depth=coder%par_depth coder%proc_nret=nret coder%par_state=par_state_outer - coder%run_mode=sym_complete + coder%run_mode=sym_private coder%subs_index=-1 coder%run_flags=0 coder%aliased=.false. @@ -4994,6 +5338,8 @@ subroutine restore_proc_state coder%subs_index=save_subs_index coder%aliased=save_aliased coder%in_sync=save_in_sync + coder%state_base=save_state_base + coder%mask=save_mask end subroutine restore_proc_state subroutine code_params(cblock,iscomm,argcall) @@ -5009,7 +5355,7 @@ subroutine code_params(cblock,iscomm,argcall) do i=1,node_numargs(p),2 flags=var_is_param name=node_arg(p,i) - if(name%offset==sym_arg) flags=var_is_varg + if(name%offset==sym_dotdotdot) flags=var_is_varg call make_var(coder,cblock,p,name,flags) enddo else @@ -5026,7 +5372,7 @@ subroutine code_params(cblock,iscomm,argcall) flags=var_is_param endif name=node_arg(p,i) - if(name%offset==sym_arg) flags=var_is_varg + if(name%offset==sym_dotdotdot) flags=var_is_varg call make_var(coder,cblock,p,name,flags) enddo endif @@ -5230,6 +5576,8 @@ subroutine code_loop_startup(cblock,cblock2,cblock3) type(pm_ptr),intent(out):: cblock2,cblock3 integer:: iter + cblock3=cblock + cblock2=cblock !!$ !coder%over_base=coder%top !!$ call push_var(coder,sym_for,& @@ -5304,6 +5652,48 @@ end subroutine code_loop_finish end subroutine trav_proc + !======================================================== + ! Traverse a procedure parameter list + ! !!! stuff to say + !======================================================== + subroutine trav_params(coder,cblock,paramlist,amps,step,pre_args) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,paramlist + integer,intent(in):: amps,step,pre_args + + integer:: i,j,k,flags,nargs,name + type(pm_ptr):: amp + nargs=node_numargs(paramlist) + if(amps==0) then + do i=1,nargs,step + flags=var_is_param + name=node_num_arg(paramlist,i) + if(name==sym_dotdotdot) flags=var_is_varg + call make_sys_var(coder,cblock,paramlist,name,flags) + enddo + else + j=0 + k=0 + amp=pm_name_val(coder%context,amps) + do i=1,nargs,step + k=k+1 + if(amp%data%i(amp%offset+j)==k) then + flags=var_is_ref+var_is_param+var_is_var + if(j' - + do i=cnode_numargs(sig),1,-1 proc1=cnode_arg(sig,i) typ1=cnode_get_num(proc1,pr_ptype) @@ -5576,7 +5971,7 @@ subroutine sort_sig(coder,sig,signo) do while(j<=cnode_numargs(sig)) proc2=cnode_arg(sig,j) typ2=cnode_get_num(proc2,pr_ptype) - + if(debug_codegen) then write(*,*) 'COMPARE SIGS>',typ1,typ2 write(*,*) '--------------------------------------' @@ -5585,24 +5980,31 @@ subroutine sort_sig(coder,sig,signo) write(*,*) '--------------------------------------' endif if(cnode_get_num(proc1,pr_nret)/=cnode_get_num(proc2,pr_nret).or.& - iand(cnode_get_num(proc1,pr_flags),proc_is_comm+proc_is_cond)/=& - iand(cnode_get_num(proc2,pr_flags),proc_is_comm+proc_is_cond)) then + iand(cnode_get_num(proc1,pr_flags),proccall_is_comm+proc_is_cond)/=& + iand(cnode_get_num(proc2,pr_flags),proccall_is_comm+proc_is_cond)) then if(debug_more_codegen) write(*,*) 'SIG DIFFERENT' sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 j=j+1 - else if(typ1==typ2) then - call cnode_error(coder,proc1,& - 'Procedure "'//trim(sig_name_str(coder,signo))//& - '" defined with identical signatures:'//& - trim(pm_type_as_string(coder%context,typ2))) - call cnode_error(coder,sig%data%ptr(j+1),& - 'Conflicting definition') - return else if(pm_type_includes(coder%context,typ2,typ1,pm_type_incl_type,& einfo)) then - if(debug_more_codegen) write(*,*) 'SIG INCL' - call check_nesting(proc1,proc2) - exit + if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type,& + einfo)) then + if(.not.pm_type_has_when(coder%context,typ2)) then + call cnode_error(coder,proc1,& + 'Procedure "'//trim(sig_name_str(coder,signo))//& + '" defined with identical signatures:'//& + trim(pm_type_as_string(coder%context,typ2))) + call cnode_error(coder,proc2,'Conflicting definition') + return + else + sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 + j=j+1 + endif + else + if(debug_more_codegen) write(*,*) 'SIG INCL' + call check_nesting(proc1,proc2) + exit + endif else if(debug_more_codegen) write(*,*) 'SIG NOT INCL' if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type,& @@ -5615,7 +6017,7 @@ subroutine sort_sig(coder,sig,signo) enddo sig%data%ptr(sig%offset+cnode_args+j-2)=proc1 enddo - + contains include 'fesize.inc' @@ -5624,7 +6026,7 @@ subroutine check_nesting(first,second) logical:: isbad integer:: ret1,ret2,rtype1,rtype2,ii type(pm_ptr):: tv1,tv2 - + if(cnode_flags_clear(second,& pr_flags,proc_is_open)) then if(.not.(cnode_get(first,cnode_modl_name)==& @@ -5635,7 +6037,7 @@ subroutine check_nesting(first,second) 'Conflicting definition') endif endif - + ret1=cnode_get_num(second,pr_rtype) ret2=cnode_get_num(first,pr_rtype) tv1=pm_type_vect(coder%context,ret1) @@ -5661,7 +6063,7 @@ subroutine check_nesting(first,second) 'but in this procedure has type: '//& trim(pm_type_as_string(coder%context,rtype2))) isbad=.true. - + endif enddo if(isbad) then @@ -5669,9 +6071,9 @@ subroutine check_nesting(first,second) 'Original procedure in above error') endif endif - + end subroutine check_nesting - + end subroutine sort_sig @@ -5932,6 +6334,9 @@ function find_var(coder,name) result(v) i=find_var_entry(coder,n,coder%proc_base) if(i/=0) then v=coder%var(i) + if(i<=coder%block_base) then + call import_to_block_scope(coder,i,v,coder%block_entry) + endif else v=pm_null_obj endif @@ -5951,6 +6356,9 @@ function find_var_and_entry(coder,name,i) result(v) i=find_var_entry(coder,n,coder%proc_base) if(i/=0) then v=coder%var(i) + if(i<=coder%block_base) then + call import_to_block_scope(coder,i,v,coder%block_entry) + endif else v=pm_null_obj endif @@ -6288,7 +6696,7 @@ subroutine make_const(coder,cblock,node,val,typ) tno=pm_fast_typeof(val) endif if(coder%par_state/=par_state_outer) then - tno=pm_type_add_mode(coder%context,tno,sym_mirrored,.false.) + tno=pm_type_add_mode(coder%context,tno,sym_invar) endif call code_val(coder,val) call code_num(coder,tno) @@ -6337,7 +6745,7 @@ subroutine make_sp_call(coder,cblock,node,sym,nargs,nret,flags) integer:: depth,base,aflags aflags=0 if(present(flags)) aflags=flags - call make_arglist(coder,cblock,node,nargs,nret,.false.) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.) call code_null(coder) call make_full_call(coder,cblock,node,& pm_fast_tinyint(coder%context,-sym),pm_null_obj,nargs,abs(nret),0,& @@ -6367,7 +6775,7 @@ subroutine make_basic_sp_call(coder,cblock,node,sym,nargs,nret,depth) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: sym,nargs,nret,depth - call make_arglist(coder,cblock,node,nargs,nret,.false.,notouch=.true.) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.,notouch=.true.) call code_null(coder) call make_full_call(coder,cblock,node,& pm_fast_tinyint(coder%context,-sym),pm_null_obj,& @@ -6397,16 +6805,18 @@ subroutine make_sys_call(coder,cblock,node,sym,& endif flags=ior(flags,coder%run_flags) if(present(assign)) then - avec=coder%one + avec=coder%std_amp else avec=pm_null_obj endif - call make_arglist(coder,cblock,node,nargs,nret,.false.) + + call make_arglist(coder,cblock,node,nargs,nret,.true.,.false.) call code_null(coder) procs=find_sig(coder,node,& pm_fast_name(coder%context,sym)) call make_full_call(coder,cblock,node,& - procs,avec,nargs,abs(nret),0,pm_null_obj,flags,pm_null_obj,coder%par_depth) + procs,avec,nargs+1,abs(nret),0,& + pm_null_obj,flags,pm_null_obj,coder%par_depth) contains include 'fname.inc' end subroutine make_sys_call @@ -6443,9 +6853,9 @@ subroutine make_comm_sys_call(coder,cblock,node,sym,& integer:: depth,flags,base,narg narg=nargs+num_comm_args if(present(aflags)) then - flags=ior(aflags,call_is_comm) + flags=ior(aflags,proccall_is_comm) else - flags=call_is_comm + flags=proccall_is_comm endif if(present(assign)) then avec=coder%comm_amp @@ -6454,10 +6864,11 @@ subroutine make_comm_sys_call(coder,cblock,node,sym,& endif procs=find_sig(coder,node,& pm_fast_name(coder%context,sym)) - call make_arglist(coder,cblock,node,nargs,nret,.true.) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.true.) call code_null(coder) call make_full_call(coder,cblock,node,& - procs,avec,narg,abs(nret),0,pm_null_obj,flags,pm_null_obj,coder%par_depth) + procs,avec,narg,abs(nret),0,pm_null_obj,flags,& + pm_null_obj,coder%par_depth) contains include 'fname.inc' end subroutine make_comm_sys_call @@ -6504,10 +6915,10 @@ subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,depth,flags) type(pm_ptr):: procs,svect procs=find_sig(coder,node,& pm_fast_name(coder%context,sym)) - call make_arglist(coder,cblock,node,narg,nret,.false.,.true.) + call make_arglist(coder,cblock,node,narg,nret,.true.,.false.,.true.) call code_null(coder) call make_full_call(coder,cblock,node,& - procs,pm_null_obj,narg,abs(nret),0,pm_null_obj,& + procs,pm_null_obj,narg+1,abs(nret),0,pm_null_obj,& ior(flags,coder%run_flags),pm_null_obj,depth) contains include 'fname.inc' @@ -6579,11 +6990,11 @@ end subroutine make_full_call ! - if nret<0 then nret temp variables created and left ! on vstack before the argument list cnode !======================================================== - subroutine make_arglist(coder,cblock,node,nargs,nret,iscomm,notouch) + subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,iscomm,notouch) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: nargs,nret - logical,intent(in):: iscomm + logical,intent(in):: isstd,iscomm logical,intent(in),optional:: notouch integer:: i,ret0,arg0,extra0,nextra,base type(pm_ptr):: arglist @@ -6606,21 +7017,30 @@ subroutine make_arglist(coder,cblock,node,nargs,nret,iscomm,notouch) endif if(iscomm) then - extra0=coder%par_base - nextra=5 + extra0=coder%state_base + nextra=num_comm_args-1 + elseif(isstd) then + extra0=coder%state_base + nextra=1 else - extra0=coder%par_base+1 + extra0=coder%state_base nextra=0 endif - arglist=make_arglist_cnode(coder,node,abs(nret),ret0,nextra,extra0,nargs,arg0) - if(nret<0.and.ret0>base) then - do i=1,-nret - coder%vstack(base+i)=coder%vstack(ret0+i) - enddo - coder%vtop=base-nret+1 + + arglist=make_arglist_cnode(coder,node,abs(nret),ret0,nextra,extra0,iscomm,nargs,arg0) + if(nret<0) then + if(ret0>base) then + do i=1,-nret + coder%vstack(base+i)=coder%vstack(ret0+i) + enddo + coder%vtop=base-nret+1 + else + coder%vtop=base-nret+1 + endif else - coder%vtop=base+1 + coder%vtop=base+1 endif + coder%vstack(coder%vtop)=arglist contains include 'fvkind.inc' @@ -6632,11 +7052,6 @@ subroutine update_arg(p) if(pm_fast_vkind(p)==pm_pointer) then if(cnode_get_kind(p)==cnode_is_var) then call update_change_lists(coder,p,.false.) - if(cnode_flags_set(p,var_flags,var_is_accessed)) then - call cnode_set_flags(p,var_flags,var_is_multi_access) - else - call cnode_set_flags(p,var_flags,var_is_accessed) - endif endif endif end subroutine update_arg @@ -6703,6 +7118,12 @@ subroutine make_code(coder,node,ckind,nargs) type(pm_ptr),intent(in):: node integer,intent(in):: ckind,nargs integer:: i + if(pm_debug_checks) then + if(coder%vtop-nargs<0) then + write(*,*) '#',coder%vtop,'<',nargs + call pm_panic('make code - not enough values on stack') + endif + endif call make_code_stem(coder,node,ckind,nargs) coder%temp%data%ptr(coder%temp%offset+5:coder%temp%offset+4+nargs)=& coder%vstack(coder%vtop-nargs+1:coder%vtop) @@ -6716,20 +7137,30 @@ subroutine make_code(coder,node,ckind,nargs) coder%vstack(coder%vtop)=coder%temp end subroutine make_code - function make_arglist_cnode(coder,node,nret,ret0,nextra,extra0,nargs,args0) result(arglist) + !=========================================================== + ! Make a combined argument list cnode, built as follows + ! vstack(ret0+1)..vstack(ret0+nret) var(extra0+1..extra0+nextra) + ! [ var(coder%mask) if mask ] vstack(args0+1..args0+nargs) + !=========================================================== + function make_arglist_cnode(coder,node,nret,ret0,nextra,extra0,mask,nargs,args0) result(arglist) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: node integer,intent(in):: nret,ret0,nextra,extra0,nargs,args0 + logical,intent(in):: mask type(pm_ptr):: arglist integer:: i,j,totargs - totargs=nret+nextra+nargs - !write(*,*) '####',nret,ret0,nextra,extra0,nargs,args0 + totargs=nret+nextra+nargs+merge(1,0,mask) + !write(*,*) '####',nret,ret0,nextra,extra0,nargs,args0,mask call make_code_stem(coder,node,cnode_is_arglist,totargs) - j=coder%temp%offset+5 + j=coder%temp%offset+cnode_args coder%temp%data%ptr(j:j+nret-1)=coder%vstack(ret0+1:ret0+nret) j=j+nret - coder%temp%data%ptr(j:j+nextra-1)=coder%vstack(extra0+1:extra0+nextra) + coder%temp%data%ptr(j:j+nextra-1)=coder%var(extra0+1:extra0+nextra) j=j+nextra + if(mask) then + coder%temp%data%ptr(j)=coder%var(coder%mask) + j=j+1 + endif coder%temp%data%ptr(j:j+nargs-1)=coder%vstack(args0+1:args0+nargs) if(pm_debug_checks) then if(j+nargs/=coder%temp%offset+5+totargs) call pm_panic('make_arglist') @@ -6749,14 +7180,12 @@ subroutine make_code_stem(coder,node,ckind,nargs) integer,intent(in):: ckind,nargs type(pm_ptr):: modl integer:: i,ii - if(pm_debug_checks) then - if(coder%vtop-nargs<0) call pm_panic('make code') - endif coder%temp=pm_fast_newnc(coder%context,pm_pointer,& nargs+cnode_args) if(pm_debug_checks.and..false.) then if(coder%temp%data%ptr(coder%temp%offset)%offset& ==cnode_magic_no) then + write(*,*) '------------' call qdump_code_tree(coder,pm_null_obj,62,coder%temp,2) do ii=1,coder%vtop call qdump_code_tree(coder,pm_null_obj,63,coder%vstack(ii),2) @@ -7137,9 +7566,9 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) if(.not.pm_fast_isnull(cnode_get(node,call_var))) then write(iunit,*) spaces(1:depth*2),'Callvar:' call qdump_code_tree(coder,rvec,iunit,& - cnode_get(node,call_var),depth+1) + cnode_get(node,call_var),depth+1) endif - + write(iunit,*) spaces(1:depth*2),')' case(cnode_is_builtin) if(cnode_get_num(node,cnode_args)>=0) then @@ -7157,16 +7586,6 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) 'Proc [nargs=',& cnode_get_num(node,pr_nargs),',nret=',cnode_get_num(node,pr_nret),& ',ncalls=',cnode_get_num(node,pr_ncalls),',flags=',cnode_get_num(node,pr_flags),'] (' - if(cnode_flags_set(node,pr_flags,proc_is_comm)) & - write(iunit,*) spaces(1:depth*2+1),'[loop]' - if(cnode_flags_set(node,pr_flags,proc_is_each_proc)) & - write(iunit,*) spaces(1:depth*2+1),'[each]' - if(cnode_flags_set(node,pr_flags,proc_is_dup_each)) & - write(iunit,*) spaces(1:depth*2+1),'[dup-each]' - if(cnode_flags_set(node,pr_flags,proc_is_thru_each)) & - write(iunit,*) spaces(1:depth*2+1),'[thru-each]' - if(cnode_flags_set(node,pr_flags,proc_is_empty_each)) & - write(iunit,*) spaces(1:depth*2+1),'[empty-each]' call qdump_code_tree(coder,rvec,iunit,& cnode_arg(node,1),depth+1) write(iunit,*) spaces(1:depth*2),')' @@ -7181,41 +7600,30 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) write(iunit,*) spaces(1:depth*2+1),'[impure]' if(cnode_flags_set(node,cnode_args+2,proc_is_not_inlinable)) & write(iunit,*) spaces(1:depth*2+1),'[not inlinable]' - if(cnode_flags_set(node,cnode_args+2,proc_is_not_pure_each)) & - write(iunit,*) spaces(1:depth*2+1),'[not pure each]' call qdump_code_tree(coder,cnode_arg(node,2),& iunit,cnode_arg(node,1),depth+1) - write(iunit,*) spaces(1:depth*2),')' - case(cnode_is_arglist) - write(iunit,*) spaces(1:depth*2),'Var Sig List(',cnode_numargs(node) - if(cnode_flags_set(node,cnode_args+1,proc_is_var)) then - do i=5,cnode_numargs(node),2 - write(iunit,*) spaces(1:depth*2),& - trim(pm_name_as_string(coder%context,& - cnode_get_name(node,cnode_args+i-1))),'-->',& - cnode_get_num(node,cnode_args+i) - enddo - else - write(iunit,*) spaces(1:depth*2),'Sig List(',cnode_numargs(node) - do i=2,cnode_numargs(node),2 - write(iunit,*) spaces(1:depth*2),trim(pm_type_as_string(coder%context,& - cnode_get_num(node,cnode_args+i-1))) - call qdump_code_tree(coder,rvec,iunit,cnode_arg(node,i+1),depth+1) - enddo - endif - write(iunit,*) spaces(1:depth*2),')' - case(cnode_is_any_sig) - write(iunit,*) spaces(1:depth*2),'Any signature (' - do i=1,cnode_numargs(node) - call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) - enddo - write(iunit,*) spaces(1:depth*2),')' - case(cnode_is_autoconv_sig) - write(iunit,*) spaces(1:depth*2),'Auto convert signature (' - do i=1,cnode_numargs(node) - call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) - enddo - write(iunit,*) spaces(1:depth*2),')' + write(iunit,*) spaces(1:depth*2),')' + case(cnode_is_arglist) + write(iunit,*) spaces(1:depth*2),'Var Sig List(',cnode_numargs(node) + write(iunit,*) spaces(1:depth*2),'Sig List(',cnode_numargs(node) + do i=2,cnode_numargs(node),2 + write(iunit,*) spaces(1:depth*2),trim(pm_type_as_string(coder%context,& + cnode_get_num(node,cnode_args+i-1))) + call qdump_code_tree(coder,rvec,iunit,cnode_arg(node,i+1),depth+1) + enddo + write(iunit,*) spaces(1:depth*2),')' + case(cnode_is_any_sig) + write(iunit,*) spaces(1:depth*2),'Any signature (' + do i=1,cnode_numargs(node) + call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) + enddo + write(iunit,*) spaces(1:depth*2),')' + case(cnode_is_autoconv_sig) + write(iunit,*) spaces(1:depth*2),'Auto convert signature (' + do i=1,cnode_numargs(node) + call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) + enddo + write(iunit,*) spaces(1:depth*2),')' case default write(iunit,*) spaces(1:depth*2),'<>' end select @@ -7235,8 +7643,12 @@ function sig_name(coder,m) result(name) integer,intent(in):: m integer:: name type(pm_ptr):: key - key=pm_dict_key(coder%context,coder%sig_cache,int(m,pm_ln)) - name=key%data%i(key%offset+pm_fast_esize(key)) + if(m==0) then + name=sym_var + else + key=pm_dict_key(coder%context,coder%sig_cache,int(m,pm_ln)) + name=key%data%i(key%offset+pm_fast_esize(key)) + endif contains include 'fesize.inc' end function sig_name @@ -7248,7 +7660,11 @@ function sig_name_str(coder,m) result(str) type(code_state),intent(in):: coder integer,intent(in):: m character(len=100):: str - call pm_name_string(coder%context,sig_name(coder,m),str) + if(m==0) then + str='var' + else + call pm_name_string(coder%context,sig_name(coder,m),str) + endif end function sig_name_str !============================================ @@ -7275,12 +7691,6 @@ subroutine dump_sigs(coder,iunit) ',nret=',sig%data%i(sig%offset+pm_fast_esize(sig)-1),') (' if(pm_fast_vkind(code)==pm_int) then call pm_dump_tree(coder%context,iunit,code,2) - elseif(cnode_flags_set(code,cnode_args+1,proc_is_var)) then - do j=3,cnode_numargs(code),2 - write(iunit,*) trim(pm_name_as_string(coder%context,& - cnode_get_name(code,j+cnode_args-1))) - write(iunit,*) cnode_get_num(code,j+cnode_args) - enddo else do j=3,cnode_numargs(code),2 typ=cnode_arg(code,j) @@ -7355,12 +7765,12 @@ function sig_as_str(coder,name,ampl,numargs,nret,flags,args) result(str) endif call pm_name_string(coder%context,int(name%offset),str(n:)) n=len_trim(str)+1 - if(iand(flags,call_is_comm)/=0) then + if(iand(flags,proccall_is_comm)/=0) then str(n:n)='%' n=n+1 endif if(present(args).and.& - iand(flags,proc_is_comm)/=0) then + iand(flags,proccall_is_comm)/=0) then str(n:n)='(' n=n+1 do i=num_comm_args+1,nargs @@ -7419,7 +7829,7 @@ function sig_as_str(coder,name,ampl,numargs,nret,flags,args) result(str) endif str(n:n)=')' if(.not.present(args).and.& - iand(flags,proc_is_comm)/=0& + iand(flags,proccall_is_comm)/=0& .and.coder%par_state>=par_state_cond) then str(n+2:)='Conditional context' endif diff --git a/src/infer.f90 b/src/infer.f90 index e6a29d1..9c18237 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -44,7 +44,6 @@ module pm_infer use pm_lib use pm_symbol use pm_types - use pm_parser use pm_cnodes use pm_codegen use pm_vmdefs @@ -153,17 +152,19 @@ end subroutine inf_prog ! Returns signature index as tiny int in on vstack ! ==================================================== function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& - keynames,keybase,proc_nkeys) result(rtype) + keynames,keybase,proc_nkeys,nomatch,only_when) result(rtype) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: procnode,callnode integer,intent(in):: atype,ptype integer,intent(in):: nret,nkeys,keybase,proc_nkeys + logical,intent(in):: only_when + logical,intent(out):: nomatch type(pm_ptr),intent(in):: keynames type(pm_ptr):: cnode,cac integer:: rtype integer:: at integer,dimension(4+proc_nkeys):: key - integer:: i,j,keysize,nk + integer:: i,j,keysize,nk,tno integer(pm_ln):: k logical:: save_redo_calls,save_incomplete integer:: taints,save_taints @@ -190,7 +191,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& return endif - iscomm=cnode_flags_set(procnode,pr_flags,proc_is_comm) + iscomm=cnode_flags_set(procnode,pr_flags,proccall_is_comm) ! Dictionary entries in coder%proc_cache: ! Key is proc and argument types and implicit par_kind @@ -220,6 +221,31 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call inf_error_with_trace(coder,procnode,& 'Procedure definition corresponding to the above error') endif + + nomatch=.false. + if(.not.pm_fast_isnull(cnode_get(procnode,pr_when))) then + if(proc_nkeys==0) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) + call inf_arg_types(coder,procnode,atype) + call inf_cblock(coder,cnode_get(procnode,pr_when)) + tno=get_arg_type(coder,callnode,cnode_get(procnode,pr_whenvar)) + if(tno==coder%false_fix.or.tno==coder%false_literal) then + call pop_stack_frame(coder) + nomatch=.true. + return + elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then + call inf_error(coder,procnode,& + '"when" expression must have a fixed or literal bool value') + call more_error(coder%context,'Type of expression is: '//& + trim(pm_type_as_string(coder%context,tno))) + endif + endif + + if(only_when) then + call pop_stack_frame(coder) + nomatch=.false. + return + endif if(debug_inference) then write(*,*) 'PRC PROC>',key(1),key(2),k,& @@ -326,7 +352,10 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& save_incomplete=coder%incomplete save_taints=coder%taints - if(proc_nkeys==0) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + if(proc_nkeys==0.and.pm_fast_isnull(cnode_get(procnode,pr_when))) then + call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + endif + do if(debug_inference) write(*,*) 'TRY>',key(1),key(2),rtype @@ -436,8 +465,8 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call code_int_vec(coder,coder%stack,coder%base,coder%top) call code_num(coder,& ior(iand(cnode_get_num(procnode,pr_flags),& - proc_is_comm+proc_run_shared+proc_run_local+proc_inline+& - proc_no_inline+proc_run_complete+proc_run_always),& + proccall_is_comm+proc_run_shared+proc_run_local+proccall_is_inline+& + proccall_is_no_inline+proc_run_complete+proc_run_always),& coder%taints)) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) cnode=top_code(coder) @@ -469,26 +498,12 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& include 'fisnull.inc' end function inf_proc - !======================================================================= - ! Process keyword arguments - ! This requires type inference of default expressions before checking - ! and converting the arguments - !======================================================================= - subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& - keytypes,n) + subroutine inf_arg_types(coder,procnode,atype) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,procnode,call_keys - integer,intent(in):: atype,nkeys,key_base - integer,intent(out):: keytypes(*),n - integer i,j,cname,pname,ctype,ptype,dtype,pdtype,mtype - logical:: nomatch,error - type(pm_ptr):: callkeys,proc_keys,arglist,tv - integer:: nargs,totargs,tno - - proc_keys=cnode_get(procnode,pr_keys) - - ! Need to infer standard arguments in case they are - ! used in default expressions + type(pm_ptr),intent(in):: procnode + integer,intent(in):: atype + type(pm_ptr):: arglist,tv + integer:: nargs,totargs,i,j arglist=cnode_get(procnode,pr_argcall) if(.not.pm_fast_isnull(arglist)) then nargs=cnode_numargs(arglist) @@ -509,6 +524,31 @@ subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& call set_var_type(coder,cnode_arg(arglist,nargs),pop_word(coder)) endif endif + contains + include 'fisnull.inc' + end subroutine inf_arg_types + + !======================================================================= + ! Process keyword arguments + ! This requires type inference of default expressions before checking + ! and converting the arguments + !======================================================================= + subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& + keytypes,n) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode,call_keys + integer,intent(in):: atype,nkeys,key_base + integer,intent(out):: keytypes(*),n + integer i,j,cname,pname,ctype,ptype,dtype,pdtype,mtype + logical:: nomatch,error + type(pm_ptr):: callkeys,proc_keys,arglist,tv + integer:: nargs,totargs,tno + + proc_keys=cnode_get(procnode,pr_keys) + + ! Need to infer standard arguments in case they are + ! used in default expressions + call inf_arg_types(coder,procnode,atype) arglist=cnode_get(procnode,pr_keycall) n=pm_fast_esize(proc_keys)/2 @@ -583,17 +623,21 @@ end subroutine inf_key_args ! ================================================== ! Type infer builtin procedure ! =================================================== - function inf_builtin(coder,procnode,atype,ptype) result(rtype) + function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: procnode + type(pm_ptr),intent(in):: procnode,callnode integer,intent(in):: atype,ptype integer:: rtype,mode,atype1 integer,dimension(1):: key - integer:: k - type(pm_ptr):: tv + integer:: k,t1,n + type(pm_ptr):: tv,v type(pm_type_einfo):: einfo logical:: isstatic + if(debug_inference) then + write(*,*) 'BUILTIN>',trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) + endif + rtype=cnode_get_num(procnode,pr_rtype) if(rtype<0) then ! Cached concrete return type @@ -606,7 +650,7 @@ function inf_builtin(coder,procnode,atype,ptype) result(rtype) endif endif - atype1=pm_type_arg(coder%context,atype,1) + atype1=pm_type_strip_mode(coder%context,pm_type_arg(coder%context,atype,2),mode) ! special handling of return types for some operations select case(cnode_get_num(procnode,bi_opcode)) @@ -619,14 +663,50 @@ function inf_builtin(coder,procnode,atype,ptype) result(rtype) case(op_get_dom) rtype=pm_type_arg(coder%context,atype1,2) case(op_as,op_get_poly_or) - rtype=pm_type_arg(coder%context,atype,2) + rtype=pm_type_arg(coder%context,atype,3) case(op_import_val,op_import_varg,op_broadcast_val,& op_clone,op_get_rf) rtype=atype1 case(op_elem) - rtype=pm_type_arg(coder%context,& - pm_type_strip_mode(coder%context,atype1,mode),& - cnode_get_num(procnode,bi_opcode2)) + n=cnode_get_num(procnode,bi_opcode2) + if(n/=0) then + tv=pm_type_vect(coder%context,atype1) + k=pm_tv_kind(tv) + if(k==pm_type_is_vect) then + t1=pm_tv_arg(tv,1) + tv=pm_type_vect(coder%context,t1) + rtype=pm_type_strip_mode(coder%context,pm_tv_arg(tv,n-1),mode) + if(modepm_tv_numargs(tv)) then + call inf_error(coder,callnode,& + '".element_at_index": index out of bounds: '//& + trim(pm_int_as_string(n))) + call more_error(coder%context,'Type being indexed: '//& + trim(pm_type_as_string(coder%context,t1))) + call inf_trace(coder) + rtype=error_type + else + rtype=pm_tv_arg(tv,n) + endif + endif case(op_make_array,op_pack) rtype=pm_new_arr_type(coder%context,sym_const,atype1,& pm_type_arg(coder%context,atype,2),int(pm_long)) @@ -637,7 +717,7 @@ function inf_builtin(coder,procnode,atype,ptype) result(rtype) tv=pm_type_vect(coder%context,atype1) rtype=pm_new_arr_type(coder%context,pm_tv_name(tv),& pm_tv_arg(tv,1),& - pm_type_arg(coder%context,atype,2),int(pm_long)) + pm_type_arg(coder%context,atype,3),int(pm_long)) case(op_make_type_val) rtype=pm_new_type_type(coder%context,atype1) case(op_import_dref) @@ -726,7 +806,7 @@ function inf_builtin(coder,procnode,atype,ptype) result(rtype) !!$ rtype=pm_tv_arg(tv,1) !!$ tv=pm_type_vect(coder%context,rtype) !!$ rtype=pm_type_strip_mode(coder%context,pm_tv_arg(tv,int(sym-sym_d1+1)),mode) -!!$ if(mode0.and.coder%par_kind==par_mode_conc.and.mode==sym_shared) then if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then call inf_error_with_trace(coder,callnode,& @@ -995,17 +1074,21 @@ subroutine inf_call(coder,cblock,callnode) ' to a non-communicating operation') endif call push_word(coder,& - pm_type_add_mode(coder%context,tno,sym_mirrored,.false.)) + pm_type_add_mode(coder%context,tno,sym_invar)) enddo call make_type(coder,n+2) tno=pop_word(coder) coder%stack(get_slot(1))=tno call flag_import_export(tno) endif + case(sym_null) + do i=1,nret + coder%stack(get_slot(i))=pm_null + enddo case(sym_export) tno=arg_type_with_mode(1) mode=pm_type_get_mode(coder%context,tno) - if(mode/=sym_coherent.and.mode/=sym_partial) then + if(mode/=sym_private) then call inf_error(coder,callnode,& 'Cannot modify "'//trim(sym_names(mode))//'" variable as a "shared" value '//& 'in a nested parallel statement: '//& @@ -1094,89 +1177,6 @@ subroutine inf_call(coder,cblock,callnode) if(debug_inference) write(*,*) 'DREF=',& trim(pm_type_as_string(coder%context,top_word(coder))) coder%stack(get_slot(1))=pop_word(coder) - case(sym_hash) - if(arg_type(2)/=pm_null) then - call inf_cblock(coder,cnode_arg(args,1)) - endif - case(sym_for_stmt) - coder%taints=ior(coder%taints,proc_needs_par) - tno=coder%par_kind - coder%stack(get_slot(1))=pm_long - coder%stack(get_slot(2))=tno - if(tno==error_type) tno=pm_null - if(tno>par_mode_multi_node.or.arg_type(7)==pm_null) then - save_par_kind=coder%par_kind2 - coder%par_kind2=coder%par_kind - if(tno>par_mode_multi_node) then - coder%par_kind=par_mode_inner - else - coder%par_kind=par_mode_conc - endif - slot=get_slot(1) - coder%stack(slot)=pm_long - slot=get_slot(2) - coder%stack(slot)=pm_null - call inf_cblock(coder,cnode_arg(args,4)) - call inf_cblock(coder,cnode_arg(args,3)) - call make_code(coder,pm_null_obj,cnode_is_any_sig,0) - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - else - save_par_kind=coder%par_kind2 - coder%par_kind2=coder%par_kind - coder%par_kind=par_mode_multi_node - nerrors=coder%num_errors - call inf_cblock(coder,cnode_arg(args,4)) - list=cnode_arg(args,8) - list=cnode_arg(list,1) - slot=list%data%i(list%offset) - slot2=list%data%i(list%offset+1) - coder%stack(coder%base+slot:coder%base+slot2)=undefined - call inf_cblock(coder,cnode_arg(args,3)) - coder%par_kind2=save_par_kind - if(coder%num_errors==nerrors) then - call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) - coder%stack(coder%base+slot:coder%base+slot2)=undefined - coder%par_kind=par_mode_single_node - call inf_cblock(coder,cnode_arg(args,3)) - if(coder%num_errors==nerrors) then - call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) - call inf_cblock(coder,cnode_arg(args,5)) - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - if(coder%num_errors==nerrors) then - call make_code(coder,pm_null_obj,cnode_is_any_sig,2) - else - call drop_code(coder) - call drop_code(coder) - return - endif - else - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - call drop_code(coder) - return - endif - else - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - return - endif - endif - list=pop_code(coder) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - call set_call_sig(int(k)) - case(sym_pct) - if(nargs==1) then - call inf_cblock(coder,cnode_arg(args,1)) - else - tno=arg_type(3) - slot=get_slot(1) - coder%stack(slot)=tno - call inf_cblock(coder,cnode_arg(args,2)) - endif case(sym_struct,sym_rec) t=cnode_arg(args,2) t=cnode_arg(t,1) @@ -1215,7 +1215,7 @@ subroutine inf_call(coder,cblock,callnode) trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset-mode)))) endif - mode=sym_mirrored + mode=sym_invar endif do i=1,nargs-2 tno2=pm_type_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+2+i),mode2) @@ -1249,10 +1249,21 @@ subroutine inf_call(coder,cblock,callnode) tno2=error_type endif endif - tno2=pm_type_add_mode(coder%context,tno2,mode,& - cnode_flags_set(callnode,call_flags,call_is_cond)) - call combine_types(cnode_arg(args,1),tno2) - case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref) + tno2=pm_type_add_mode(coder%context,tno2,mode) + call combine_types(cnode_arg(args,1),tno2) + case(sym_open_smiley) + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + do i=1,nargs + call push_word(coder,arg_type_with_mode(i+1)) + enddo + mode=pm_type_mix_modes(coder%context,& + coder%wstack(coder%wtop-nargs+1:coder%wtop)) + call make_type_if_possible(coder,nargs+2) + tno2=pop_word(coder) + tno2=pm_type_add_mode(coder%context,tno2,mode) + call combine_types(cnode_arg(args,1),tno2) + case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref) if(sig==sym_get_dot.or.sig==sym_get_dot_ref) then tno=arg_type(3) if(tno/=error_type) then @@ -1271,13 +1282,13 @@ subroutine inf_call(coder,cblock,callnode) if(tno==error_type) then call set_arg_to_error_type(1) else - tno=pm_type_strip_mode_and_cond(coder%context,& - tno,mode,cond) + tno=pm_type_strip_mode(coder%context,& + tno,mode) if(tno>0) then call set_call_sig(resolve_elem(tno,name,& sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) call combine_types(cnode_arg(args,1),& - pm_type_add_mode(coder%context,tno2,mode,cond)) + pm_type_add_mode(coder%context,tno2,mode)) else call set_arg_to_error_type(1) endif @@ -1297,38 +1308,37 @@ subroutine inf_call(coder,cblock,callnode) call set_arg_to_error_type(1) return endif - tno2=pm_type_strip_mode_and_cond(coder%context,& - arg_type_with_mode(2),mode,cond) + tno2=pm_type_strip_mode(coder%context,& + arg_type_with_mode(2),mode) k=inf_cast(coder,callnode,tno,tno2,.true.) call set_call_sig(int(k)) call combine_types(cnode_arg(args,1),& - pm_type_add_mode(coder%context,tno2,mode,cond)) + pm_type_add_mode(coder%context,tno2,mode)) case(sym_var_set_mode) mode2=cnode_num_arg(args,2) coder%stack(get_slot(1))=pm_type_add_mode(coder%context,& pm_type_strip_mode(coder%context,& - arg_type_with_mode(1),mode),mode2,.false.) - if(mode==sym_partial.or.& - mode2>=sym_mirrored.and.mode=sym_invar.and.mode=sym_mirrored) then + if(tno>=sym_invar) then call inf_error(coder,callnode,& 'Assignments to "'//trim(sym_names(tno))//& '" variables are not allowed outside of a "sync" statement') @@ -1401,7 +1411,7 @@ subroutine inf_call(coder,cblock,callnode) coder%stack(get_slot(1))=tno case(sym_dcaret) coder%stack(get_slot(1))=pm_type_add_mode(coder%context,& - pm_new_vect_type(coder%context,arg_type(2)),sym_shared,.false.) + pm_new_vect_type(coder%context,arg_type(2)),sym_shared) case(sym_open) if(nargs>0) then t=pm_type_vect(coder%context,coder%stack(coder%base)) @@ -1440,8 +1450,6 @@ subroutine inf_call(coder,cblock,callnode) coder%stack(get_slot(2))=pm_logical case(sym_underscore,sym_colon,sym_end_loop,sym_init_var) continue - case(sym_arg) - call combine_types(cnode_arg(args,1),arg_type(2)) case(first_pragma:last_pragma) if(sig==sym_infer_type.or.sig==sym_infer_type_and_stack) then call inf_cblock(coder,cnode_arg(args,1)) @@ -1556,7 +1564,7 @@ subroutine inf_any(nupdates) writelist=cnode_arg(changelist,2) slot=list2%data%i(list2%offset) slot2=list2%data%i(list2%offset+1) - tno=pm_type_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) + tno=pm_type_strip_mode(coder%context,arg_type(3),mode) t=check_poly(coder,tno) if(tno/=error_type.and..not.pm_fast_isnull(t)) then n=pm_set_size(coder%context,t) @@ -1581,7 +1589,7 @@ subroutine inf_any(nupdates) tno=list%data%i(list%offset) coder%stack(coder%base+slot:coder%base+slot2)=undefined coder%stack(get_slot(1))=& - pm_type_add_mode(coder%context,tno,mode,cond) + pm_type_add_mode(coder%context,tno,mode) call inf_cblock(coder,cnode_arg(args,2)) call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) @@ -1947,13 +1955,13 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) trim(sig_name_str(coder,int(sig))),'@',& callnode%data%ptr(callnode%offset+cnode_lineno)%offset if(cnode_get_kind(args)/=cnode_is_arglist) call pm_panic('not arglist') - call qdump_code_tree(coder,pm_null_obj,6,callnode,2) + !call qdump_code_tree(coder,pm_null_obj,6,callnode,2) endif ! extract characteristics of call amps=cnode_get_num(callnode,call_amp) flags=cnode_get_num(callnode,call_flags) - is_comm=iand(flags,call_is_comm)/=0 + is_comm=iand(flags,proccall_is_comm)/=0 is_cond=iand(flags,call_is_cond)/=0 is_unlabelled=iand(flags,call_is_unlabelled)/=0 ignore_rules=cnode_flags_set(callnode,call_flags,call_ignore_rules) @@ -2024,7 +2032,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) call call_error('Cannot pass a shared value to a standard procedure') call inf_error_with_trace(coder,cnode_arg(args,nret-mode),& 'Cannot pass a shared value to a standard procedure') - mode=sym_coherent + mode=sym_private endif ! Rules for "&" arguments @@ -2032,6 +2040,8 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) if(amps/=0.and..not.ignore_rules) then amplocs=pm_name_val(coder%context,amps) do i=0,pm_fast_esize(amplocs) + call qdump_code_tree(coder,pm_null_obj,6,amplocs,2) + write(*,*) 'AMPLOC-->',amplocs%data%i(amplocs%offset+i),i,pm_fast_esize(amplocs) tno2=pm_type_strip_mode(coder%context,& coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey),mode2) if(tno2>0) then @@ -2049,7 +2059,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) endif endif endif - if(mode2/=sym_partial.and.mode2/=sym_coherent.and.(mode2/=sym_chan.or.is_unlabelled)) then + if(mode2/=sym_private.and.(mode2/=sym_chan.or.is_unlabelled)) then if(mode2==sym_chan) then call call_error('Cannot change "chan" variable in an unlabelled conditional context') else @@ -2107,10 +2117,10 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) if(.not.is_comm) then ! Apply return mode to returned values - if(mode/=sym_coherent) then + if(mode/=sym_private) then do j=1,nret coder%stack(get_slot(j))=pm_type_replace_mode(coder%context,& - coder%stack(get_slot(j)),mode,is_cond) + coder%stack(get_slot(j)),mode) enddo endif @@ -2152,11 +2162,11 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) integer,intent(in),optional:: sig_start integer:: ressig - integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass + integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass,nconsidered integer:: vbase,wbase - type(pm_ptr):: v,proc,match_proc,rtvect + type(pm_ptr):: tv,v,proc,match_proc,rtvect integer:: rt,rt2,pars,mpars,apars,tno,match_pars - logical:: ok,found,visible,found_has_no_rtypes + logical:: ok,found,visible,found_has_no_rtypes,when_no_match integer:: save_par_kind,save_par_kind2 type(pm_type_einfo):: einfo integer,dimension(1):: key @@ -2182,26 +2192,31 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) ! This is done in multiple passes with increasingly broader matching ! allowed in passes 1..3 - if(pm_debug_level>4) write(*,*) 'Checking',cnode_numargs(procs),' sigs' + if(debug_inference) write(*,*) 'Checking',cnode_numargs(procs),' sigs' found=.false. - apars=error_type - + apars=0 + outer: do jpass=0,3 if(debug_inference) write(*,*) 'MATCH PASS> ',jpass + nconsidered=0 do i=1,cnode_numargs(procs) proc=cnode_arg(procs,i) - + if(debug_inference) write(*,*) 'CHECK nret',cnode_get_num(proc,pr_nret),nret,& + 'amps',cnode_get_num(proc,pr_amps),amps,& + 'comm',cnode_flags_set(proc,pr_flags,proccall_is_comm),is_comm if(cnode_get_num(proc,pr_nret)/=nret) cycle if(cnode_get_num(proc,pr_amps)/=amps) cycle - if(cnode_flags_set(proc,pr_flags,proc_is_comm).neqv.is_comm) cycle - !!! Deal with cond/uncond here + if(iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general)/=& + iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general)) cycle + + nconsidered=nconsidered+1 pars=cnode_get_num(proc,pr_ptype) if(debug_inference) then write(*,*) 'CHECKING SIG',(i-1)/2,& ' OF ',(cnode_numargs(procs)-2)/2,& - ' FOR>',trim(sig_name_str(coder,int(sig))) + ' FOR> ',trim(sig_name_str(coder,int(sig))) write(*,*) '>> ',trim(pm_type_as_string(coder%context,pars)) endif @@ -2215,8 +2230,11 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) ! Check for a visible match if(is_visible(coder,callnode,proc)) visible=.true. - ! If this is a second (or later) match, then check for compatibility + !!$ ! If this is a second (or later) match, then check for compatibility if(found) then + if(debug_inference) write(*,*) 'SECOND MATCH>',& + trim(pm_type_as_string(coder%context,pars)),'AFTER>',& + trim(pm_type_as_string(coder%context,match_pars)) if(pm_type_includes(coder%context,pars,& match_pars,pm_type_incl_type,einfo)) then coder%wtop=wbase @@ -2240,20 +2258,38 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) endif endif endif + if(pm_type_has_when(coder%context,pars)) then + if(pm_type_includes(coder%context,match_pars,& + pars,pm_type_incl_type,einfo)) then + ! Two equally specific when procs - the second must have when(false) + coder%trace_depth=coder%trace_depth+1 + if(coder%trace_depth',coder%vtop,start,coder%incomplete @@ -2305,7 +2339,14 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) else !if(coder%vtop/=pcheck+1) call pm_panic('pcheck mismatch') endif - endif + endif + + found=.true. + match_pars=pars + match_proc=proc + found_has_no_rtypes=& + pm_type_kind(coder%context,cnode_get_num(match_proc,pr_rtype))==& + pm_type_is_undef_result if(nret>0) then if(rt>0) then @@ -2354,29 +2395,36 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) if(.not.present(err)) then if(.not.found) then call cnode_error(coder,callnode,& - 'No matching procedure:') + 'No matching procedure returning '//trim(pm_int_as_string(nret))//' value'//& + merge(': ','s:',nret==1)) else call cnode_error(coder,callnode,& - 'No matching procedure visible to module containing call') + 'No matching procedure is visible to the module containing the call') + call more_error(coder%context,'(expecting '//trim(pm_int_as_string(nret))//' return value'//& + merge(': ','s:',nret==1)) endif m=coder%wtop call make_type(coder,nargs+2) call print_call_details(coder,callnode,keybase,nargs) coder%wtop=m - - call more_error(coder%context,'Procedures considered:') - do m=1,cnode_numargs(procs) - pars=cnode_get_num(cnode_arg(procs,m),pr_ptype) - call print_proc_details(coder,cnode_arg(procs,m),& - sig,& - cnode_flags_set(callnode,call_flags,call_is_comm),& - pars) - if(m>pm_opts%proc_list.and..not.pm_opts%see_all_procs) then - call more_error(coder%context,& - '... (to see all procedures use -fsee-all-procs)') - exit - endif - enddo + call more_error(coder%context,'Procedures considered:') + do m=1,cnode_numargs(procs) + proc=cnode_arg(procs,m) + if(nconsidered/=0) then + if(cnode_get_num(proc,pr_nret)/=nret) cycle + if(cnode_get_num(proc,pr_amps)/=amps) cycle + if(iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general)/=& + iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general)) cycle + endif + pars=cnode_get_num(proc,pr_ptype) + call print_proc_details(coder,proc) + if(m>pm_opts%proc_list.and..not.pm_opts%see_all_procs) then + call more_error(coder%context,& + '... (to see all procedures use -fsee-all-procs)') + exit + endif + enddo + call inf_trace(coder) do i=1,nret call set_arg_to_error_type(i) @@ -2415,6 +2463,8 @@ function var_call(callnode) result(ressig) integer:: proctyp,tno,name,start,arg(1) logical:: err + write(*,*) 'var call enter>',coder%wtop + ! Get value for procedure name (actually its type) var=cnode_get(callnode,call_var) if(cnode_get_kind(var)==cnode_is_var) then @@ -2457,7 +2507,7 @@ function var_call(callnode) result(ressig) ressig=simple_proc_call(sig,pr,sig_start=start) if(ressig>0) call check_returns_against_sig(proctyp,tv,callnode) ! Pop off extra set of arg types pushed by match_call_sig - coder%top=coder%wtop-nargs-2 + coder%wtop=coder%wtop-nargs-2 else call inf_error(coder,callnode,& 'Call arguments do not match procedure type'//& @@ -2477,6 +2527,8 @@ function var_call(callnode) result(ressig) call set_arg_to_error_type(i) enddo ressig=undefined + + write(*,*) 'var call end>',coder%wtop end function var_call !======================================================= @@ -2487,35 +2539,38 @@ end function var_call subroutine check_call_against_sig(tno,tvp,callnode) integer,intent(in):: tno type(pm_ptr),intent(in):: tvp,callnode - integer:: tno2,i,k,tno3 - type(pm_ptr):: tv,tv2,tv3,amplocs - type(pm_type_einfo):: einfo - integer:: nret,flags,n,mode,argmode + type(pm_ptr):: tv + integer:: flags,kind tv=pm_type_vect(coder%context,pm_tv_arg(tvp,1)) ! Get information on call - nret=cnode_get_num(callnode,call_nret) flags=cnode_get_num(callnode,call_flags) + if(iand(flags,proccall_is_ref)/=0) then + kind=sym_dot + elseif(iand(flags,proccall_is_general)/=0) then + kind=sym_dash + elseif(iand(flags,proccall_is_comm)/=0) then + kind=sym_pct + else + kind=sym_proc + endif - ! Check type of call - name=pm_tv_name(tv) - if(iand(flags,call_is_comm)/=0) then - if(name/=sym_pct) then - call inf_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Expecting communicating "%" procedure') - endif - elseif(name/=sym_proc) then + if(pm_tv_name(tv)/=kind) then call inf_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Not expecting communicating "%" procedure') + 'Call does not match procedure type ("'//& + trim(pm_name_as_string(coder%context,pm_tv_name(tv)))//'" vs "'//& + trim(pm_name_as_string(coder%context,kind))//'"):'//& + trim(pm_type_as_string(coder%context,tno))) endif + if(iand(pm_tv_flags(tv),pm_type_is_yield)/=0.neqv.& + cnode_flags_set(callnode,call_flags,proccall_is_yield)) then + call inf_error(coder,callnode,& + 'Call does not match procedure type ("yield")'//& + trim(pm_type_as_string(coder%context,tno))) + endif + end subroutine check_call_against_sig !======================================================= @@ -2523,43 +2578,55 @@ end subroutine check_call_against_sig ! then it is necessary to check the returned values against ! the signature !======================================================= - subroutine check_returns_against_sig(tno,tvp,callsig) + subroutine check_returns_against_sig(tno,tvp,callnode) integer,intent(in):: tno - type(pm_ptr),intent(in):: tvp,callsig + type(pm_ptr),intent(in):: tvp,callnode type(pm_ptr):: tv2 - integer:: tno2,tno3,i,k,n,at + integer:: tno2,nret + integer:: tno3,i,k,n,at type(pm_type_einfo):: einfo + nret=cnode_get_num(callnode,call_nret) + ! Check returns - tno2=pm_tv_arg(tv,2) + tno2=pm_type_arg(coder%context,pm_tv_arg(tvp,1),2) tv2=pm_type_vect(coder%context,tno2) - n=pm_tv_numargs(tv2) - if(nret/=n) then - call inf_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_type_as_string(coder%context,tno)) - call more_error(coder%context,'Different number of return values') - return - endif - do i=1,n - at=get_var_type(coder,callnode,cnode_arg(args,i)) - if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& - at,pm_type_incl_val,einfo)) then - - - !!!! Check conversion to interface/proc_sig - + if(pm_tv_kind(tv2)==pm_type_is_undef_result) then + if(nret/=pm_tv_name(tv2)) then call inf_error(coder,callnode,& 'Call does not match procedure type: '//& pm_type_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Return type mismatch: '//& - trim(pm_type_as_string(coder%context,pm_tv_arg(tv2,i)))//& - ' vs: '//& - trim(pm_type_as_string(coder%context,at))) + call more_error(coder%context,'Call has a different number of return values: '//& + trim(pm_int_as_string(nret))//' vs '//trim(pm_int_as_string(pm_tv_name(tv2)))) + return endif - enddo - + else + n=pm_tv_numargs(tv2) + if(nret/=n) then + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,'Different number of return values: '//& + trim(pm_int_as_string(nret))//' vs '//trim(pm_int_as_string(n))) + return + endif + + do i=1,n + at=get_var_type(coder,callnode,cnode_arg(args,i)) + if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& + at,pm_type_incl_val,einfo)) then + + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,& + 'Return type mismatch: '//& + trim(pm_type_as_string(coder%context,pm_tv_arg(tv2,i)))//& + ' vs: '//& + trim(pm_type_as_string(coder%context,at))) + endif + enddo + endif return 10 continue @@ -2695,6 +2762,12 @@ function match_call_sig(coder,callnode,procnode,pars,& endif pv=pm_type_vect(coder%context,pars) pk=pm_tv_kind(pv) + n=pm_tv_numargs(pv) + + if(n>nargs) then + argtyp=undefined + return + endif if(pm_debug_checks) then if(pk/=pm_type_is_tuple.and.& @@ -2723,7 +2796,6 @@ function match_call_sig(coder,callnode,procnode,pars,& coder%wstack(wbase+2)=0 ! Process each argument, converting if required - n=pm_tv_numargs(pv) do i=1,nargs at=coder%wstack(wbase-nargs+i) if(at==undefined) call pm_panic('broken type resolution chain') @@ -3310,13 +3382,12 @@ function fold(coder,procnode,atype,rstype) result(rtype) integer:: rtyp type(pm_type_einfo):: einfo - tv=pm_type_vect(coder%context,atype) - n=pm_tv_numargs(tv) + n=pm_tv_numargs(tv)-1 opcode=cnode_get_num(procnode,bi_opcode) if(opcode==op_num_elems_fold) then coder%temp=pm_fast_newnc(coder%context,pm_long,1) - tno=pm_tv_arg(tv,1) + tno=pm_tv_arg(tv,2) tk=pm_type_kind(coder%context,tno) if(tk/=pm_type_is_struct.and.tk/=pm_type_is_rec) then call inf_error_with_trace(coder,procnode,& @@ -3331,10 +3402,10 @@ function fold(coder,procnode,atype,rstype) result(rtype) return elseif(opcode==op_type_include_fold) then ok=pm_type_includes(coder%context,& - pm_type_arg(coder%context,& - pm_type_arg(coder%context,atype,1),1),& pm_type_arg(coder%context,& pm_type_arg(coder%context,atype,2),1),& + pm_type_arg(coder%context,& + pm_type_arg(coder%context,atype,3),1),& pm_type_incl_type,einfo) if(ok) then rtype=coder%true_literal @@ -3344,10 +3415,10 @@ function fold(coder,procnode,atype,rstype) result(rtype) return endif arg1=pm_dict_val(coder%context,coder%context%tcache,& - int(pm_tv_arg(tv,1),pm_ln)) + int(pm_tv_arg(tv,2),pm_ln)) if(n>1) then arg2=pm_dict_val(coder%context,coder%context%tcache,& - int(pm_tv_arg(tv,2),pm_ln)) + int(pm_tv_arg(tv,3),pm_ln)) endif rtyp=pm_type_strip_to_basic(coder%context,pm_type_arg(coder%context,rstype,1)) @@ -3375,8 +3446,8 @@ function fold(coder,procnode,atype,rstype) result(rtype) endif else if(opcode==op_eq_fold.or.opcode==op_ne_fold) then - ok=pm_type_name(coder%context,pm_tv_arg(tv,1))==& - pm_type_name(coder%context,pm_tv_arg(tv,2)) + ok=pm_type_name(coder%context,pm_tv_arg(tv,2))==& + pm_type_name(coder%context,pm_tv_arg(tv,3)) if(opcode==op_ne_fold) ok=.not.ok else call fold_comparison(opcode,arg1,arg2,ok) @@ -3640,12 +3711,6 @@ subroutine inf_trace(coder) top=top-1 node=coder%trace(top) if(.not.hide(node)) then -!!$ call pm_error_header(coder%context,& -!!$ cnode_get_name(node,cnode_modl_name),& -!!$ cnode_get_name(node,cnode_lineno),& -!!$ cnode_get_name(node,cnode_charno)) -!!$ top=top-1 -!!$ if(top<1) return exit endif enddo @@ -3710,6 +3775,7 @@ subroutine print_call_details(coder,node,base,numargs) integer:: i character(len=100):: str character(len=2):: join,ampstr + character(len=1):: procchr,dotchr integer:: n,k,nargs,nkeys integer::ampidx,signame,signamebase type(pm_ptr):: tv,key,val,amp,keyargs,keynames,name @@ -3717,18 +3783,8 @@ subroutine print_call_details(coder,node,base,numargs) if(coder%supress_errors) return nargs=cnode_numargs(cnode_get(node,call_args))-cnode_get_num(node,call_nret) if(present(numargs)) nargs=numargs - k=0 - key=pm_dict_key(coder%context,& - coder%sig_cache,int(cnode_get_num(node,call_sig),pm_ln)) - val=pm_dict_val(coder%context,& - coder%sig_cache,int(cnode_get_num(node,call_sig),pm_ln)) - keyargs=cnode_get(node,call_keys) - if(pm_fast_isnull(keyargs)) then - nkeys=0 - else - nkeys=cnode_numargs(cnode_get(node,call_keys)) - endif - + + nkeys=0 ampidx=cnode_get_num(node,call_amp) if(ampidx==0) then amp=pm_null_obj @@ -3759,25 +3815,34 @@ subroutine print_call_details(coder,node,base,numargs) signamebase==sym_make_sublhs_amp) then signame=sym_sub endif - if(cnode_flags_clear(node,call_flags,& - call_is_comm)) then - call more_error(coder%context,' '//trim(pm_name_as_string(coder%context,& - signame))//' (') - n=0 + + + if(cnode_flags_set(node,call_flags,proccall_is_comm)) then + n=6 + if(cnode_flags_set(node,call_flags,proccall_is_general)) then + procchr='''' + else + procchr='%' + endif + else + n=1 + procchr=' ' + endif + + if(cnode_flags_set(node,call_flags,proccall_is_ref)) then + procchr=' ' + dotchr='.' else - call more_error(coder%context,' '//trim(pm_name_as_string(coder%context,& - signame))//'%(') - call more_error(coder%context,' region: '//& - trim(pm_type_as_string(coder%context,& - coder%wstack(base+1),distr=.true.))) - call more_error(coder%context,' schedule: '//& - trim(pm_type_as_string(coder%context,& - coder%wstack(base+2),distr=.true.))) - call more_error(coder%context,' here: '//& - trim(pm_type_as_string(coder%context,& - coder%wstack(base+3),distr=.true.))) - n=3 + dotchr=' ' + endif + + if(cnode_flags_set(node,call_flags,proccall_is_yield)) then + n=n+3 endif + + call more_error(coder%context,dotchr//trim(pm_name_as_string(coder%context,& + signame))//procchr//' (') + k=0 do i=n+1,nargs if(i0) then join=', ' @@ -3804,7 +3869,15 @@ subroutine print_call_details(coder,node,base,numargs) ' = '//& trim(pm_type_as_string(coder%context,coder%wstack(base+i)))//join) enddo - call more_error(coder%context,' )') + + if(cnode_flags_set(node,call_flags,proccall_is_yield)) then + call more_error(coder%context,' ) yield (') + call more_error(coder%context,' '//& + trim(pm_type_as_string(coder%context,coder%wstack(base+nkeys+2+n-2)))) + call more_error(coder%context,' )') + else + call more_error(coder%context,' )') + endif contains include 'fesize.inc' include 'fisnull.inc' @@ -3833,30 +3906,15 @@ end subroutine print_call_details ! Print details of procedure definition ! with given signature (sig) and parameter types (tno) ! ==================================================== - subroutine print_proc_details(coder,node,sig,iscomm,tno) + subroutine print_proc_details(coder,node) type(code_state):: coder type(pm_ptr),intent(in):: node - integer,intent(in):: sig - logical,intent(in):: iscomm - integer,intent(in):: tno - integer:: name,ampidx - integer:: i,k,n,nx,nargs - integer:: typ - type(pm_ptr):: tv,tv2,key,amp,val - character(len=256):: str,str2 - character(len=7):: buf1,buf2 + integer:: name + integer:: istart,n,tno,nret,i + character(len=512):: str,str2,buf1,buf2 if(.not.pm_main_process) return if(coder%supress_errors) return - k=0 - key=pm_dict_key(coder%context,coder%sig_cache,int(sig,pm_ln)) - val=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) - name=key%data%i(key%offset+pm_fast_esize(key)) - ampidx=key%data%i(key%offset+pm_fast_esize(key)-2) - if(ampidx==0) then - amp=pm_null_obj - else - amp=pm_name_val(coder%context,ampidx) - endif + name=cnode_get_num(node,pr_name) str=' ' call pm_name_string(coder%context,& cnode_get_name(node,cnode_modl_name),str2) @@ -3875,63 +3933,51 @@ subroutine print_proc_details(coder,node,sig,iscomm,tno) endif endif n=max(len_trim(str)+2,20) - if(add_char(':')) goto 777 + str(n:n)=':' n=n+2 + nret=cnode_get_num(node,pr_nret) + do i=1,nret-1 + str(n:n+1)='_,' + n=n+1 + enddo + if(nret>0) then + str(n:n+1)='_=' + n=n+1 + endif + + if(cnode_flags_set(node,pr_flags,proccall_is_ref)) then + str(n:n)='.' + n=n+1 + endif call pm_name_string(coder%context,name,str(n:)) n=len_trim(str)+1 - if(.not.iscomm) then - if(pm_fast_isnull(amp)) then - str(n:)=pm_type_as_string(coder%context,tno) + if(cnode_flags_set(node,pr_flags,proccall_is_ref)) then + istart=7 + elseif(cnode_flags_set(node,pr_flags,proccall_is_comm)) then + if(cnode_flags_set(node,pr_flags,proccall_is_general)) then + str(n:n)='''' else - tv=pm_type_vect(coder%context,tno) - nargs=pm_tv_numargs(tv) - nx=0 - if(add_char('(')) goto 777 - do i=1,nargs - call check_amp - typ=pm_tv_arg(tv,i) - call pm_type_to_string(coder%context,typ,str,n,.false.) - if(n>len(str)-10) goto 777 - if(ilen(str)-20) then + str(n:n+2)='...' + else + if(cnode_flags_set(node,pr_flags,proccall_is_yield)) then + str(n:)=')yield(' + n=n+7 + tno=pm_type_arg(coder%context,tno,istart) + call pm_type_to_string(coder%context,tno,str,n) + str(n:n)=')' endif - if(n>len(str)-10) goto 777 - nargs=pm_tv_numargs(tv) - do i=4,nargs - call check_amp - typ=pm_tv_arg(tv,i) - call pm_type_to_string(coder%context,typ,str,n,.false.) - if(n>len(str)-10) goto 777 - if(ilen(str)-10-len(c)) then - str(n:n+2)='...' - term=.true. - else - str(n:n+len(c)-1)=c - n=n+len(c) - term=.false. - endif - end function add_char - subroutine check_amp - logical:: junk - if(pm_fast_isnull(amp)) return - if(k>pm_fast_esize(amp)) return - if(amp%data%i(amp%offset+k)==i) then - k=k+1 - junk=add_char('&') - endif - end subroutine check_amp - end subroutine print_proc_details diff --git a/src/lib.f90 b/src/lib.f90 index a393b54..21c3c6d 100755 --- a/src/lib.f90 +++ b/src/lib.f90 @@ -299,10 +299,18 @@ function pm_int_as_string(num) result(str) integer:: n,j,k,m,d n=num m=1 + j=1 + if(n==0) then + str='0' + return + elseif(n<0) then + str(j:j)='-' + j=2 + n=-n + endif do while(m<=n) m=m*10 enddo - j=1 do while(m>1.and.j<=field_width) m=m/10 d=n/m diff --git a/src/parser.f90 b/src/parser.f90 index 6aa7090..e8d1003 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -40,8 +40,7 @@ module pm_parser implicit none ! Print out lots of parser debugging info - logical,parameter:: debug_parser=.true. - logical,parameter:: debug_parser_extra=.false. + logical,parameter:: debug_parser=.false. ! Check if memory manager attempts to reuse a node ! (this should not happen so is one test of gc) @@ -60,7 +59,7 @@ module pm_parser integer:: ls,lineno,sym_lineno,name_lineno,old_sym_lineno logical:: newline,atstart integer:: n, sym_n, name_sym_n,old_sym_n, last, iunit - type(pm_ptr):: temp, lexval + type(pm_ptr):: temp, lexval,single_amp integer:: sym, pushback integer,dimension(max_parse_stack):: stack integer:: top @@ -124,6 +123,11 @@ subroutine init_parser(parser,context) pm_fast_tinyint(parser%context,i),& .true.,.false.,ok) enddo + + ! Create parser%si + call push_sym(parser,1) + call name_vector(parser,1) + parser%single_amp=pop_val(parser) contains include 'ftiny.inc' end subroutine init_parser @@ -278,7 +282,7 @@ subroutine next_line(parser) parser%ls=3-parser%ls endif parser%lineno=parser%lineno+1 - if(debug_parser_extra) write(*,*) 'Now at line',parser%lineno + if(debug_parser) write(*,*) 'Now at line',parser%lineno if(parser%iunit>=0) then call pm_read_line(parser%iunit,parser%line(parser%ls),ios) if(ios/=0) goto 10 @@ -420,15 +424,23 @@ subroutine scan(parser) case(';') sym=sym_semi case('(') - if(peekchar()=='.') then - c=getchar() - sym=sym_open_brace - elseif(peekchar()=='/') then + select case(peekchar()) + case('%') + if(peekchar_plus(1)/=':') then + c=getchar() + sym=sym_open_brace + else + sym=sym_open + endif + case('/') c=getchar() sym=sym_open_square - else + case(':') + c=getchar() + sym=sym_open_smiley + case default sym=sym_open - endif + end select case(')') sym=sym_close case('+') @@ -442,9 +454,6 @@ subroutine scan(parser) if(peekchar()=='>') then c=getchar() sym=sym_arrow - elseif(peekchar()==':') then - c=getchar() - sym=sym_tilde else sym=sym_minus endif @@ -459,6 +468,9 @@ subroutine scan(parser) if(peekchar()=='=') then c=getchar() sym=sym_ne + elseif(peekchar()=='!') then + c=getchar() + sym=sym_tilde else sym=sym_pling endif @@ -480,9 +492,9 @@ subroutine scan(parser) case(':') c=getchar() sym=sym_dcolon - case('=') + case(')') c=getchar() - sym=sym_assign + sym=sym_close_smiley case default sym=sym_colon end select @@ -494,7 +506,7 @@ subroutine scan(parser) c=getchar() sym=sym_cond else - sym=sym_define + sym=sym_assign endif case('>') if(peekchar()=='=') then @@ -523,6 +535,9 @@ subroutine scan(parser) elseif(peekchar()==':') then c=getchar() sym=sym_hash + elseif(peekchar()==')') then + c=getchar() + sym=sym_close_brace else sym=sym_pct endif @@ -538,9 +553,6 @@ subroutine scan(parser) elseif(iachar(peekchar())>=iachar('1').and.iachar(peekchar())<=iachar('7')) then c=getchar() sym=sym_d1+iachar(c)-iachar('1') - elseif(peekchar()==')') then - c=getchar() - sym=sym_close_brace else sym=sym_dot endif @@ -590,12 +602,7 @@ subroutine scan(parser) sym=sym_dash endif case('&') - if(peekchar()=='&') then - c=getchar() - sym=sym_damp - else - sym=sym_amp - endif + sym=sym_amp case('$') if(peekchar()=='$') then c=getchar() @@ -649,7 +656,7 @@ subroutine scan(parser) parser%atstart=.false. endif parser%sym=sym - if(debug_parser_extra) then + if(debug_parser) then if(parser%sym>=0.and.parser%sym<=num_sym) then write(*,*) 'scan::',parser%sym,sym_names(parser%sym) else @@ -676,7 +683,7 @@ function peekchar() result(ch) ch=parser%line(parser%ls)(parser%n:parser%n) end function peekchar - ! Look at next character but one on line but do not advance + ! Look at next character but m on line but do not advance function peekchar_plus(m) result(ch) integer,intent(in)::m character(len=1):: ch @@ -1206,38 +1213,65 @@ end function proccall !====================================================== ! Argument lists for procedure calls !====================================================== - recursive function arglist(parser,object) result(iserr) + recursive function arglist(parser,yield) result(iserr) type(parse_state),intent(inout):: parser - type(pm_ptr),intent(in),optional:: object + logical,intent(in),optional:: yield logical:: iserr integer m,n,base,sym,flags,line,pos type(pm_ptr):: temp iserr=.true. call get_sym_pos(parser,line,pos) - m=0 n=0 base=parser%top - + if(parser%sym==sym_pct) then - flags=call_is_comm + flags=proccall_is_comm + call scan(parser) + elseif(parser%sym==sym_dash) then + flags=proccall_is_comm+proccall_is_general call scan(parser) + elseif(present(yield)) then + flags=proccall_is_yield else flags=0 endif - - if(flags/=0) then + + call push_sym_val(parser,sym_topology) + call make_node(parser,sym_name,1) + m=1 + if(iand(flags,proccall_is_comm)/=0) then + call push_sym_val(parser,sym_outer) + call make_node(parser,sym_name,1) call push_sym_val(parser,sym_region) call make_node(parser,sym_name,1) call push_sym_val(parser,sym_subregion) call make_node(parser,sym_name,1) call push_sym_val(parser,sym_here_in_tile) call make_node(parser,sym_name,1) - m=3 + call push_sym_val(parser,sym_mask) + call make_node(parser,sym_name,1) + m=num_comm_args endif - if(present(object)) then - call push_val(parser,object) - m=m+1 + if(present(yield)) then + if(yield) then + call push_sym_val(parser,sym_block_inouts) + call push_sym(parser,m+1) + call make_node(parser,sym_name,1) + call push_sym_val(parser,sym_block_ins) + call make_node(parser,sym_name,1) + m=m+2 + else + call push_sym_val(parser,sym_block_proc_a) + call make_node(parser,sym_name,1) + call push_sym_val(parser,sym_block_inouts_a) + call make_node(parser,sym_name,1) + call push_sym(parser,m+2) + call push_sym_val(parser,sym_block_ins_a) + call make_node(parser,sym_name,1) + m=m+3 + endif + endif if(expect(parser,sym_open)) return @@ -1270,9 +1304,9 @@ recursive function arglist(parser,object) result(iserr) if(valref(parser)) return m=m+1 call push_sym(parser,m) - else if(parser%sym==sym_arg) then - call push_sym_val(parser,sym_arg) - call make_node(parser,sym_arg,1) + else if(parser%sym==sym_dotdotdot) then + call push_sym_val(parser,sym_dotdotdot) + call make_node(parser,sym_dotdotdot,1) call make_node(parser,sym_dotdotdot,m+1) if(parser%top>base) then call name_vector(parser,base) @@ -1281,11 +1315,10 @@ recursive function arglist(parser,object) result(iserr) endif base=parser%top call scan(parser) - if(expect(parser,sym_dotdotdot)) return exit else if(check_name(parser,sym)) then - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call make_node(parser,sym_list,m) if(parser%top>base) then call name_vector(parser,base) @@ -1326,7 +1359,7 @@ recursive function arglist(parser,object) result(iserr) if(expect_name(parser,& 'keyword argument name')) return endif - if(expect(parser,sym_define,& + if(expect(parser,sym_assign,& 'keyword argument "="')) return if(expr(parser)) return n=n+1 @@ -1370,11 +1403,11 @@ recursive function qual(parser,dot_call) result(iserr) type(parse_state),intent(inout):: parser logical,intent(inout),optional:: dot_call logical:: iserr - integer:: sym,line,pos + integer:: sym,line,pos,n iserr=.true. if(parser%sym==sym_pling) then call scan(parser) - call make_node(parser,sym_at,1) + call make_node(parser,sym_pling,1) endif do select case(parser%sym) @@ -1399,7 +1432,7 @@ recursive function qual(parser,dot_call) result(iserr) case(sym_open_square) if(subscript(parser)) return call make_node_at(parser,sym_dot_sub,2,line,pos) - case(sym_open,sym_pct) + case(sym_open,sym_pct,sym_dash) call make_node_at(parser,sym_dot,1,line,pos) if(arglist(parser)) return if(present(dot_call)) then @@ -1410,32 +1443,15 @@ recursive function qual(parser,dot_call) result(iserr) case default if(expect_name(parser)) return sym=parser%sym - if(sym==sym_open.or.sym==sym_pct) then - parser%temp=parser%vstack(parser%vtop-1) - call make_node_at(parser,sym_method_call,1,line,pos) - call swap_vals(parser) - call drop_val(parser) - if(arglist(parser,parser%temp)) return - if(present(dot_call)) then - dot_call=.true. - iserr=.false. - return + if(sym==sym_open) then + call scan(parser) + if(parser%sym==sym_close) then + call make_node(parser,sym_list,0) + else + if(exprlist(parser)) return endif - - ! This supports implementation of lhs calls at some point -!!$ select case(parser%sym) -!!$ case(sym_dot,sym_open_square,sym_d1:sym_d7,sym_pling,sym_at,& -!!$ sym_assign,sym_comma) -!!$ call push_val(parser,parser%temp) -!!$ call make_node(parser,sym_dot_amp,2) -!!$ case default -!!$ if(present(dot_call)) then -!!$ dot_call=.true. -!!$ iserr=.false. -!!$ return -!!$ endif -!!$ end select - + if(expect(parser,sym_close)) return + call make_node(parser,sym_dot_call,3) else call make_node_at(parser,sym_dot,2,line,pos) endif @@ -1449,9 +1465,6 @@ recursive function qual(parser,dot_call) result(iserr) call get_sym_pos(parser,line,pos) if(subscript(parser)) return call make_node_at(parser,sym_sub,2,line,pos) -!!$ case(sym_at) -!!$ call scan(parser) -!!$ call make_node(parser,sym_at,1) case default exit end select @@ -1590,14 +1603,6 @@ recursive function op(parser,sym,isconst,istype) result(iserr) call scan(parser) if(expect(parser,sym_close_square)) return sym=sym_sub - case(sym_dotdotdot) - call scan(parser) - if(expect(parser,sym_underscore)) return - sym=sym_to_range - case(sym_underscore) - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - sym=sym_from_range case default if(.not.check_name(parser,sym)) then call parse_error(parser,'Malformed "proc" identifier') @@ -1650,9 +1655,9 @@ recursive function struct_gen(parser) result(iserr) 'Expected name of struct or rec element') return endif - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return if(expr(parser)) return - call make_node_at(parser,sym_define,1,line,pos) + call make_node_at(parser,sym_assign,1,line,pos) if(parser%sym/=sym_comma) exit call scan(parser) enddo @@ -1665,6 +1670,9 @@ recursive function struct_gen(parser) result(iserr) iserr=.false. end function struct_gen + !====================================================== + ! Tuple former + !====================================================== recursive function tuple(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr @@ -1732,20 +1740,6 @@ recursive function term(parser,checkqual) result(iserr) enddo if(expect(parser,sym_close)) return call make_node(parser,sym_switch_expr,m) - case(sym_coherent,sym_mirrored,sym_shared) - call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - call push_sym_val(parser,sym) - if(parser%sym==sym_open_attr) then - call scan(parser) - if(expect(parser,sym_always)) return - if(expect(parser,sym_close_attr)) return - call make_node(parser,sym_always,2) - else - call make_node(parser,sym_mode,2) - endif - if(expect(parser,sym_close)) return case(sym_open) call scan(parser) if(expr(parser)) return @@ -1790,21 +1784,21 @@ recursive function term(parser,checkqual) result(iserr) call scan(parser) if(op(parser,name,.true.,.false.)) return call push_sym_val(parser,name) - if(parser%sym==sym_dash.and.name>num_sym) then + if(parser%sym==sym_dcolon.and.name>num_sym) then call scan(parser) if(expect_name(parser)) return call make_node(parser,sym_proc,2) else call make_node(parser,sym_proc,1) endif - if(parser%sym==sym_open.or.parser%sym==sym_pct) then + if(parser%sym==sym_open.or.parser%sym==sym_pct.or.parser%sym==sym_dash) then if(arglist(parser)) return endif case(sym_param) call scan(parser) if(expect(parser,sym_open_brace)) return if(expect_name(parser)) return - if(parser%sym==sym_dash) then + if(parser%sym==sym_dcolon) then call scan(parser) if(expect_name(parser)) return call make_node(parser,sym_param,2) @@ -1817,6 +1811,11 @@ recursive function term(parser,checkqual) result(iserr) if(typ(parser)) return if(expect(parser,sym_gt)) return call make_node(parser,sym_type_val,1) + case(sym_open_smiley) + call scan(parser) + if(exprlist(parser,m,nolist=.true.)) return + if(expect(parser,sym_close_smiley)) return + call make_node(parser,sym_open_smiley,m) case(sym_fix) call scan(parser) if(parser%sym==sym_open_square) then @@ -1925,15 +1924,15 @@ recursive function term(parser,checkqual) result(iserr) case default if(check_name_pos(parser,name,line,pos)) then select case(parser%sym) - case(sym_open,sym_pct) + case(sym_open,sym_pct,sym_dash) if(proccall(parser,name)) return - case(sym_dash) + case(sym_dcolon) call scan(parser) call push_name_val_at(parser,name,line,pos) if(expect_name(parser)) return call make_node(parser,sym_use,2) if(parser%sym==sym_open.or.& - parser%sym==sym_pct) then + parser%sym==sym_pct.or.parser%sym==sym_dash) then if(arglist(parser)) return endif case default @@ -1965,17 +1964,7 @@ recursive function expr(parser) result(iserr) logical:: iserr integer:: n iserr=.true. - n=0 - do - if(expr1(parser,100)) return - n=n+1 - if(parser%sym==sym_damp) then - call scan(parser) - else - exit - endif - enddo - if(n>1) call make_node(parser,sym_damp,n) + if(expr1(parser,100)) return iserr=.false. end function expr @@ -1987,12 +1976,12 @@ recursive function expr1(parser,priority) result(iserr) integer,parameter:: priority_uhash=1 ! # (unary) integer,parameter:: priority_pow=2 ! ** integer,parameter:: priority_mult=3 ! * / - integer,parameter:: priority_uminus=4 ! - (unary) ! + integer,parameter:: priority_uminus=4 ! - (unary) ~ integer,parameter:: priority_hash=5 ! # integer,parameter:: priority_as=6 ! as integer,parameter:: priority_bitshift=7 ! shift integer,parameter:: priority_bitand=8 ! & - integer,parameter:: priority_bitxor=9 ! xor + integer,parameter:: priority_bitxor=9 ! ~ integer,parameter:: priority_bitor=10 ! | integer,parameter:: priority_mod=11 ! mod integer,parameter:: priority_add=12 ! + - @@ -2029,9 +2018,6 @@ recursive function expr1(parser,priority) result(iserr) if(unary(priority_by,sym_by)) return case(sym_ortho) if(unary(priority_ortho,sym_ortho)) return - case(sym_dotdotdot) - parser%sym=sym_to_range - if(unary(priority_dotdot,sym_to_range)) return case default if(term(parser,.true.)) return end select @@ -2070,7 +2056,7 @@ recursive function expr1(parser,priority) result(iserr) if(binary(priority_bitor)) return case(sym_amp) if(binary(priority_bitand)) return - case(sym_xor) + case(sym_tilde) if(binary(priority_bitxor)) return case(sym_shift) if(binary(priority_bitshift)) return @@ -2080,12 +2066,6 @@ recursive function expr1(parser,priority) result(iserr) if(binary_none(priority_as)) return case(sym_ortho) if(binary_none(priority_ortho)) return - case(sym_dotdotdot) - if(prioritybase) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif + if(expect(parser,sym_assign)) return + if(expect_name(parser)) return + elseif(lsym==sym_dotdotdot.or.parser%top>base) then + if(expect(parser,sym_assign)) return + else + call make_node(parser,sym_list,0) + call push_null_val(parser) + endif + if(arglist(parser,yield=.false.)) return + if(block_or_single_stmt(parser,sym_do,0,line)) return + call make_node(parser,sym_do_stmt,4) + end if is_err=.false. end function do_stmt @@ -2658,7 +2681,7 @@ recursive function if_stmt(parser) result(iserr) end function if_stmt !============================================================== - ! (var | const) { name | _ | exception) } [ : type ] [ = expr ] + ! (var | const) { name | _ } [ : type ] [ = expr ] !============================================================== recursive function var_stmt(parser,moded_stmt) result(iserr) type(parse_state),intent(inout):: parser @@ -2698,10 +2721,10 @@ recursive function var_stmt(parser,moded_stmt) result(iserr) call parse_error(parser,& 'A "'//trim(sym_names(sym))//'" statement must define at least one object') endif - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call scan(parser) if(rhs(parser,n)) return - call make_node(parser,sym_define,2) + call make_node(parser,sym_assign,2) if(subexpr(parser)) return elseif(present(moded_stmt)) then call parse_error(parser,'Must include an initialising expression in a "'//& @@ -2722,16 +2745,11 @@ recursive function mode_stmt(parser,sym) result(iserr) integer,intent(in):: sym logical:: iserr iserr=.true. - if(parser%sym==sym_var.or.parser%sym==sym_const) then - if(var_stmt(parser,moded_stmt=sym)) return - else - if(assn_or_call(parser,& - sym==sym_coherent.or.sym==sym_shared,.false.,.true.)) return - if(subexpr(parser)) return - endif - call make_node(parser,sym_list,1) - call push_sym_val(parser,sym) - call make_node(parser,sym_mode,2) +!!$ if(parser%sym==sym_var.or.parser%sym==sym_const) then +!!$ if(var_stmt(parser,moded_stmt=sym)) return +!!$ call make_node(parser,sym_list,1) +!!$ call push_sym_val(parser,sym) +!!$ call make_node(parser,sym_mode,2) iserr=.false. end function mode_stmt @@ -2798,7 +2816,7 @@ recursive function any_stmt(parser) result(iserr) endif if(expect_and_get_name(parser,name)) return call make_node(parser,sym_name,1) - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call scan(parser) call xexpr(parser) else @@ -2895,7 +2913,7 @@ recursive function par_stmt(parser) result(is_error) if(parser%sym==sym_open_attr) then call scan(parser) if(expect(parser,sym_work)) return - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return call xexpr(parser) if(expect(parser,sym_close_attr)) return has_work=.true. @@ -3020,7 +3038,7 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) do while(parser%sym>num_sym) call push_sym(parser,parser%sym) call scan(parser) - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return if(expr(parser)) return n=n+1 if(parser%sym/=sym_comma) exit @@ -3063,90 +3081,6 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) include 'fisnull.inc' end function par_attr - !====================================================================== - ! nhd {tuple {name of expr}} [bounds expr] [attr] [subexpr] block - !====================================================================== - function nhd_stmt(parser) result(iserr) - type(parse_state),intent(inout):: parser - logical:: iserr - integer:: n,m,line,line2,var_name,list_sym - iserr=.true. - line=get_sym_line(parser) - call scan(parser) - m=0 - outer: do - if(parser%sym==sym_open_square) then - if(tuple(parser)) return - if(parser%sym==sym_ortho) then - call scan(parser) - if(parser%sym/=sym_open_square) then - if(expect(parser,sym_open_square)) return - endif - if(tuple(parser)) return - call make_node(parser,sym_open_square,2) - end if - elseif(parser%sym==sym_ortho) then - call scan(parser) - if(parser%sym/=sym_open_square) then - if(expect(parser,sym_open_square)) return - endif - if(tuple(parser)) return - call make_node(parser,sym_ortho,1) - elseif(parser%sym==sym_open) then - if(expr(parser)) return - if(expect(parser,sym_close)) return - endif - n=0 - do - if(check_name(parser,var_name)) then - if(expect(parser,sym_of)) return - call push_sym_val(parser,var_name) - call make_node(parser,sym_of,1) - if(expr(parser)) return - n=n+2 - else - if(n==0) then - if(expect_name(parser)) return - endif - call make_node(parser,list_sym,n) - m=m+2 - cycle outer - endif - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - call make_node(parser,list_sym,n) - m=m+2 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo outer - call make_node(parser,sym_list,m) - - ! Bounds - if(parser%sym==sym_bounds) then - call scan(parser) - if(expr(parser)) return - else - call make_node(parser,sym_null,0) - endif - call make_node(parser,sym_bounds,1) - - ! Attributes - if(par_attr(parser,sym_block,sym_block)) return - - ! Subexpressions - call make_node(parser,sym_nhd,0) - if(subexpr(parser)) return - - ! Block - if(block_or_single_stmt(parser,sym_nhd,-1,line)) return - - ! Make node for nhd statement - ! (nhd_expr (name of_expr)*)*, bounds,attr,subexp,block - call make_node(parser,sym_nhd,5) - iserr=.false. - end function nhd_stmt - !====================================================== ! test [ expr ] [ block ] !====================================================== @@ -3223,13 +3157,11 @@ recursive subroutine stmt_list(parser,single) case(sym_switch) if(switch_stmt(parser)) goto 999 case(sym_while) - call push_null_val(parser) - if(while_stmt(parser,0)) goto 999 + if(while_stmt(parser)) goto 999 case(sym_until) - call push_null_val(parser) - if(until_stmt(parser,0)) goto 999 + if(until_stmt(parser)) goto 999 case(sym_do) - if(do_stmt(parser,0)) goto 999 + if(do_stmt(parser)) goto 999 case(sym_test) if(test_stmt(parser)) goto 999 case(sym_for,sym_conc) @@ -3247,8 +3179,6 @@ recursive subroutine stmt_list(parser,single) if(par_attr(parser,sym_block,sym_block)) goto 999 if(block_or_single_stmt(parser,sym_over,0,line)) goto 999 call make_node(parser,sym_over,3) - case(sym_nhd) - if(nhd_stmt(parser)) return case(sym_with) line=get_sym_line(parser) call scan(parser) @@ -3259,7 +3189,7 @@ recursive subroutine stmt_list(parser,single) call make_node(parser,sym_list,1) if(block_or_single_stmt(parser,sym_with,0,line)) goto 999 call make_node(parser,sym_with,2) - case(sym_underscore) + case(sym_underscore,sym_open_smiley) if(assn_or_call(parser,.false.,.true.,.true.)) goto 999 if(parser%sym==sym_check.or.parser%sym==sym_where) then if(subexpr(parser)) goto 999 @@ -3267,7 +3197,7 @@ recursive subroutine stmt_list(parser,single) case(sym_var,sym_const) if(var_stmt(parser)) goto 999 if(subexpr(parser)) goto 999 - case(sym_coherent,sym_chan,sym_mirrored,sym_shared) + case(sym_invar,sym_local,sym_chan) call scan(parser) if(mode_stmt(parser,sym)) goto 999 case(sym_dollar) @@ -3280,58 +3210,18 @@ recursive subroutine stmt_list(parser,single) case(sym_return) call make_node(parser,sym_list,k) return + case(sym_yield) + call scan(parser) + call push_name_val(parser,sym_block_proc) + call make_node(parser,sym_name,1) + call make_node(parser,sym_dot,1) + call push_back(parser,sym_dash) + if(arglist(parser,yield=.true.)) goto 999 + call make_node(parser,sym_yield,1) case default - if(check_name_pos(parser,name,line,pos)) then - ! Labelled statements - if(parser%sym==sym_gt) then - call scan(parser) - sym=parser%sym - select case(sym) - case(sym_while) - call push_sym_val(parser,name) - if(while_stmt(parser,name)) goto 999 - case(sym_until) - call push_sym_val(parser,name) - if(until_stmt(parser,name)) goto 999 - case(sym_each) - if(for_each_stmt(parser,name)) goto 999 - case(sym_do) - call push_sym_val(parser,name) - if(do_stmt(parser,name)) goto 999 - case(sym_if,sym_test,sym_any,& - sym_for,sym_conc,sym_par) - call parse_error(parser,'Cannot label a "'//trim(sym_names(sym))//'" statement') - goto 999 - case(sym_proceed) - call scan(parser) - call push_sym_val(parser,name) - call make_node_at(parser,sym_proceed,1,line,pos) - case default - call parse_error(parser,'Syntax error following ">" label') - goto 999 - end select - elseif(parser%sym==sym_colon.or.parser%sym==sym_dcolon& - .or.parser%sym==sym_open_brace) then - if(block_or_single_stmt(parser,name,0,line)) goto 999 - call push_sym_val(parser,name) - call make_node_at(parser,sym_sync,2,line,pos) - elseif(parser%sym==sym_dash) then - call scan(parser) - if(expect_name(parser)) goto 999 - call make_node(parser,sym_use,2) - if(arglist(parser)) goto 999 - call make_node(parser,sym_do,1) - if(subexpr(parser)) goto 999 - elseif(parser%sym==sym_open.or.parser%sym==sym_pct) then - call push_name_val(parser,name) - if(arglist(parser)) goto 999 - call make_node(parser,sym_do,1) - if(subexpr(parser)) goto 999 - else - call push_back_name(parser,name) - if(assn_or_call(parser,.true.,.true.,.true.)) goto 999 - if(subexpr(parser)) goto 999 - endif + if(parser%sym>num_sym) then + if(assn_or_call(parser,.true.,.true.,.true.)) goto 999 + if(subexpr(parser)) goto 999 else if(parser%sym>0.and.parser%sym/=sym_close_brace& .and.parser%sym<=last_decl) then @@ -3374,15 +3264,15 @@ function sync_assign() result(iserr) call dup_val(parser) if(qual(parser)) return select case(parser%sym) - case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_xor,sym_concat) + case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_tilde,sym_concat) call push_sym_val(parser,parser%sym) call make_node(parser,sym_proc,1) call scan(parser) - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return if(expr(parser)) return call make_node(parser,sym_sync_assign,4) case default - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return if(expr(parser)) return call make_node(parser,sym_sync_assign,3) end select @@ -3586,12 +3476,6 @@ recursive function block_or_single_stmt(parser,name1,name2,line) result(iserr) if(parser%sym==sym_colon) then call scan(parser) call stmt_list(parser,single=.true.) - elseif(parser%sym==sym_dcolon) then - call scan(parser) - call stmt_list(parser) - if(parser%sym/=sym_close_brace.and.parser%sym/=sym_eof) then - call parse_error(parser,'A block of statements starting with "::" cannot finish here') - endif else if(expect(parser,sym_open_brace)) return call stmt_list(parser) @@ -3699,7 +3583,7 @@ recursive function moded_typ(parser,modes_ok,type_needed) result(iserr) call scan(parser) if(.not.type_needed .and.(parser%sym==sym_comma.or.& parser%sym==sym_close.or.& - parser%sym==sym_define.or.& + parser%sym==sym_assign.or.& parser%sym==sym_open_attr)) then call push_null_val(parser) else @@ -3820,6 +3704,7 @@ recursive function typval(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr integer:: m,name,name2,i,base,vbase,sym,tag,line,pos + logical:: varg iserr=.true. sym=parser%sym select case(sym) @@ -3837,10 +3722,20 @@ recursive function typval(parser) result(iserr) call push_sym_val(parser,sym_dim1+m-1) call make_node(parser,sym_type,m+1) if(expect(parser,sym_close_square)) return - case(sym_lt) + case(sym_open_smiley) call scan(parser) - if(typ(parser)) return - call make_node(parser,sym_type_val,1) + if(opt_moded_typ_list(parser,m,varg)) return + if(varg) then + call make_node(parser,sym_dotdotdot,m) + else + call make_node(parser,sym_list,m) + endif + call make_node(parser,sym_open_smiley,1) + if(expect(parser,sym_close_smiley)) return + case(sym_lt) + call scan(parser) + if(typ(parser)) return + call make_node(parser,sym_type_val,1) if(expect(parser,sym_gt)) return case(sym_any) call scan(parser) @@ -3886,7 +3781,7 @@ recursive function typval(parser) result(iserr) call scan(parser) if(op(parser,name,.true.,.true.)) return call push_sym_val(parser,name) - if(parser%sym==sym_dash.and.name>num_sym) then + if(parser%sym==sym_dcolon.and.name>num_sym) then call scan(parser) if(expect_name(parser)) return call make_node(parser,sym_proc,2) @@ -3895,7 +3790,7 @@ recursive function typval(parser) result(iserr) endif case(sym_proc) call scan(parser) - if(parser%sym==sym_open.or.parser%sym==sym_pct) then + if(parser%sym==sym_open.or.parser%sym==sym_pct.or.parser%sym==sym_dash) then if(proctyp(parser)) return else call push_sym_val(parser,sym_proc) @@ -3907,38 +3802,9 @@ recursive function typval(parser) result(iserr) if(typ(parser)) return call make_node(parser,sym_contains,1) if(expect(parser,sym_close)) return - case(sym_caret) + case(sym_pm_dref:sym_pm_ref) call scan(parser) - select case(parser%sym) - case(sym_shared) - call scan(parser) - m=pm_dref_is_shared - case(sym_dot) - call scan(parser) - m=pm_dref_is_dot - case(sym_mult) - call scan(parser) - m=pm_dref_is_any - case(sym_hash) - call scan(parser) - if(parser%sym==sym_shared) then - call scan(parser) - m=pm_dref_is_shared_slice - elseif(parser%sym==sym_mult) then - call scan(parser) - m=pm_dref_is_any_slice - else - m=pm_dref_is_slice - endif - case(sym_here) - call scan(parser) - m=pm_dref_is_here - case(sym_pling) - call scan(parser) - m=pm_dref_is_ref - case default - m=pm_dref_is_var - end select + m=sym_pm_dref-sym-1 call push_num_val(parser,m) if(expect(parser,sym_open)) return if(opt_typ_list(parser,m)) return @@ -3973,7 +3839,7 @@ recursive function typval(parser) result(iserr) call scan(parser) endif endif - if(parser%sym==sym_dash) then + if(parser%sym==sym_dcolon) then call scan(parser) if(.not.check_name(parser,name2)) then call parse_error(parser,'Expected name') @@ -4030,73 +3896,50 @@ end function typval ! -- in this case parameter names are parsed and ! pushed onto the symbol stack !==================================================================== - recursive function proctyp(parser,tname,params,is_method) result(iserr) + recursive function proctyp(parser,yield) result(iserr) type(parse_state):: parser - integer,intent(in),optional:: tname - type(pm_ptr),intent(in),optional:: params - logical,intent(in),optional:: is_method + logical,intent(in),optional:: yield logical:: iserr - integer:: i,base,base2,n,m,sym,npar + integer:: i,base,n,m,sym,npar logical:: iscomm iserr=.true. + + base=parser%top call push_null_val(parser) sym=parser%sym - iscomm=sym==sym_pct - if(iscomm) then + if(sym==sym_pct.or.sym==sym_dash.or.sym==sym_dot) then + iscomm=.true. call push_sym_val(parser,sym) call scan(parser) - call make_node(parser,sym_any,0) - call make_node(parser,sym_any,0) - call make_node(parser,sym_any,0) - m=3 + do i=1,num_comm_args + call make_node(parser,sym_any,0) + enddo + m=num_comm_args else call push_sym_val(parser,sym_proc) - m=0 - endif - if(expect(parser,sym_open)) return - - if(present(tname)) then - ! First argument "this" for methods and method signatures - ! Either T(u,v) for method or *T(u,v) for method signature - if(present(is_method)) then -!!$ npar=node_numargs(params) -!!$ do i=1,npar,2 -!!$ call push_val(parser,node_arg(params,i)) -!!$ call make_node(parser,sym_type,1) -!!$ enddo - call push_sym_val(parser,tname) - call make_node(parser,sym_type,1) - else - call make_node(parser,sym_mult,0) - endif - m=m+1 + call make_node(parser,sym_any,0) + m=1 endif - - base=parser%top - if(parser%sym/=sym_close) then - do + if(present(yield)) then + call make_node(parser,sym_any,0) + call push_sym(parser,m+1) + call make_node(parser,sym_any,0) + m=m+2 + endif + + if(expect(parser,sym_open)) return + + if(parser%sym/=sym_close) then + do sym=parser%sym m=m+1 if(sym==sym_amp) then call scan(parser) - if(present(is_method)) then - if(expect_name(parser)) return - call push_sym(parser,-int(parser%vstack(parser%vtop)%offset)) - call drop_val(parser) - if(expect(parser,sym_colon)) return - else - call push_sym(parser,m) - endif + call push_sym(parser,m) if(moded_typ(parser,iscomm,.false.)) return else - if(present(is_method)) then - if(expect_name(parser)) return - call push_sym(parser,int(parser%vstack(parser%vtop)%offset)) - call drop_val(parser) - if(expect(parser,sym_colon)) return - endif if(moded_typ(parser,iscomm,.false.)) return endif if(parser%sym/=sym_comma) exit @@ -4105,15 +3948,13 @@ recursive function proctyp(parser,tname,params,is_method) result(iserr) if(parser%sym==sym_dotdotdot) then call scan(parser) call make_node(parser,sym_dotdotdot,m) - if(present(is_method)) call push_sym(parser,sym_dotdotdot) else call make_node(parser,sym_list,m) - if(present(is_method)) call push_sym(parser,sym_list) - endif + endif else call make_node(parser,sym_list,m) - if(present(is_method)) call push_sym(parser,sym_list) endif + if(expect(parser,sym_close)) return if(parser%sym==sym_arrow) then call scan(parser) @@ -4124,22 +3965,22 @@ recursive function proctyp(parser,tname,params,is_method) result(iserr) else call push_null_val(parser) endif - if(present(is_method)) then - base2=parser%top - do i=base+1,base2-1 - if(parser%stack(i)<0) then - call push_sym(parser,i) - endif - enddo + + if(parser%top>base) then + call name_vector(parser,base) else - base2=base + call push_null_val(parser) endif - if(parser%top>base2) then - call name_vector(parser,base2) + + if(.not.present(yield).and.parser%sym==sym_yield) then + call scan(parser) + call push_back(parser,sym_dash) + if(proctyp(parser,yield=.true.)) return else call push_null_val(parser) endif - call make_node(parser,sym_proc,5) + + call make_node(parser,sym_proc,6) iserr=.false. end function proctyp @@ -4211,23 +4052,78 @@ recursive function opt_typ_list(parser,m) result(iserr) iserr=.false. end function opt_typ_list + + !====================================================== + ! Comma separated list of types + ! any of which may be omitted + !====================================================== + recursive function opt_moded_typ_list(parser,m,varg) result(iserr) + type(parse_state),intent(inout):: parser + integer,intent(out):: m + logical,intent(out),optional:: varg + logical:: iserr + iserr=.true. + m=0 + do + if(parser%sym==sym_comma.or.& + parser%sym==sym_close_smiley.or.& + parser%sym==sym_dotdotdot) then + call push_null_val(parser) + else + if(moded_typ(parser,.true.,.false.)) return + endif + m=m+1 + if(present(varg).and.parser%sym==sym_dotdotdot) then + call scan(parser) + varg=.true. + exit + endif + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + iserr=.false. + end function opt_moded_typ_list + !====================================================== ! Parameter list for procedure declaration !====================================================== - recursive function param_list(parser,iscomm,param_base) result(iserr) + recursive function param_list(parser,iscomm) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: iscomm - integer,intent(in),optional:: param_base logical:: iserr integer:: m,n,i,base,last,vbase,sym,name,numloop type(pm_ptr):: temp,dom base=parser%top iserr=.true. - m=0 + m=1 n=0 - + + ! All procedure calls implicitly pass topology + call push_sym_val(parser,sym_topology) + if(parser%sym==sym_topology) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + if(parser%sym/=sym_close) then + if(expect(parser,sym_comma)) return + endif + else + call push_null_val(parser) + endif + ! For communicating procedures implicit "region" and "subregion" parameters if(iscomm) then + call push_sym_val(parser,sym_outer) + if(parser%sym==sym_outer) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + if(parser%sym/=sym_close) then + if(expect(parser,sym_comma)) return + endif + else + call push_null_val(parser) + endif call push_sym_val(parser,sym_region) if(parser%sym==sym_region) then call scan(parser) @@ -4262,37 +4158,26 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) else call push_null_val(parser) endif - m=3 - endif - - ! For methods, the parameter list is coded on the stack - if(present(param_base)) then - last=parser%top - call push_sym_val(parser,sym_this) - call push_null_val(parser) - m=m+1 - do i=param_base+1,last-1 - call push_sym_val(parser,abs(parser%stack(i))) - call push_null_val(parser) - m=m+1 - if(parser%stack(i)<0) call push_sym(parser,m) - enddo - call make_node(parser,parser%stack(last),m*2) - call push_null_val(parser) - if(parser%top>base) then - call name_vector(parser,base) + call push_sym_val(parser,sym_mask) + if(parser%sym==sym_mask) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + if(parser%sym/=sym_close) then + if(expect(parser,sym_comma)) return + endif else call push_null_val(parser) endif - iserr=.false. - return + m=num_comm_args endif - + ! Empty argument list if(parser%sym==sym_close) then call make_node(parser,sym_list,m*2) call push_null_val(parser) call push_null_val(parser) + call push_null_val(parser) call scan(parser) iserr=.false. return @@ -4300,30 +4185,25 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) ! Standard (non-keyword) arguments do - if(parser%sym==sym_arg) then + if(parser%sym==sym_dotdotdot) then call scan(parser) - if(expect(parser,sym_dotdotdot)) return - call push_sym_val(parser,sym_arg) + call push_sym_val(parser,sym_dotdotdot) if(arg_typ_with_mode(iscomm)) return call make_node(parser,sym_dotdotdot,m*2+2) exit else if(parser%sym==sym_amp) then call scan(parser) if(expect_name(parser,'argument name')) return - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call parse_error(parser,'Cannot have "=" after "&name"') return endif m=m+1 call push_sym(parser,m) if(arg_typ_with_mode(iscomm)) return - else if(parser%sym==sym_key) then - call make_node(parser,sym_list,m*2) - call push_back(parser,sym_comma) - exit else if(check_name(parser,name)) then - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call make_node(parser,sym_list,m*2) call push_sym_val(parser,name) call scan(parser) @@ -4338,7 +4218,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) call parse_error(parser,'Expected argument') endif if(arg_typ_with_mode(iscomm)) return - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then parser%temp=pop_val(parser) call drop_val(parser) call make_node(parser,sym_list,m*2) @@ -4363,19 +4243,12 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) if(parser%sym==sym_comma) then do call scan(parser) - if(parser%sym==sym_key) then - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - call make_node(parser,sym_dotdotdot,n*3) - exit - else - if(expect_name(parser, & - 'optional argument name')) return - if(arg_typ_with_mode(iscomm)) return - if(expect(parser,sym_define)) return - if(expr(parser)) return - n=n+1 - endif + if(expect_name(parser, & + 'optional argument name')) return + if(arg_typ_with_mode(iscomm)) return + if(expect(parser,sym_assign)) return + if(expr(parser)) return + n=n+1 if(parser%sym/=sym_comma) then call make_node(parser,sym_list,n*3) exit @@ -4388,13 +4261,22 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) call push_null_val(parser) endif endif - - if(expect(parser,sym_close)) return + if(parser%top>base) then call name_vector(parser,base) else call push_null_val(parser) endif + + if(parser%sym==sym_when) then + call scan(parser) + call xexpr(parser) + else + call push_null_val(parser) + endif + + if(expect(parser,sym_close)) return + iserr=.false. return contains @@ -4430,9 +4312,9 @@ function proc_comm_kinds(parser,flags) result(iserr) case(sym_pm_node) call set_flags(proc_run_local+proc_run_always) call scan(parser) - case(sym_complete) - call set_flags(proc_run_complete) - call scan(parser) +!!$ case(sym_complete) +!!$ call set_flags(proc_run_complete) +!!$ call scan(parser) case(sym_cond_attr) call set_flags(proc_is_cond) call scan(parser) @@ -4452,7 +4334,7 @@ function proc_comm_kinds(parser,flags) result(iserr) contains subroutine set_flags(new_flags) integer,intent(in):: new_flags - if(iand(flags,proc_is_comm)==0) then + if(iand(flags,proccall_is_comm)==0) then call parse_error(parser,& 'Can only apply "'//trim(sym_names(parser%sym))//& '" to a communicating procedure') @@ -4478,24 +4360,6 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) call scan(parser) do select case(parser%sym) - case(sym_each) - call set_flags(proc_is_each_proc) - if(iscall) then - call parse_error(parser,'each^ in call') - exit - endif - call scan(parser) - if(expect(parser,sym_caret)) return - if(expect(parser,sym_open)) return - m=0 - do - if(expect_name(parser)) return - m=m+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - call make_node(parser,sym_each,m) - if(expect(parser,sym_close)) return case(sym_always) if(iscall) then call parse_error(parser,& @@ -4504,10 +4368,10 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) call set_flags(proc_run_always) call scan(parser) case(sym_inline) - call set_flags(proc_inline) + call set_flags(proccall_is_inline) call scan(parser) case(sym_no_inline) - call set_flags(proc_no_inline) + call set_flags(proccall_is_no_inline) call scan(parser) case(sym_ignore_rules) call set_flags(call_ignore_rules) @@ -4519,8 +4383,8 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) if(parser%sym/=sym_comma) exit call scan(parser) enddo - if(iand(flags,proc_inline+proc_no_inline)==& - proc_inline+proc_no_inline) then + if(iand(flags,proccall_is_inline+proccall_is_no_inline)==& + proccall_is_inline+proccall_is_no_inline) then call parse_error(parser,& 'Cannot have both "<>" and "<>" attributes together') endif @@ -4542,9 +4406,8 @@ end function proc_call_attr !====================================================== ! Procedure declaration !====================================================== - function proc_decl(parser,method_name,param_base) result(iserr) + function proc_decl(parser) result(iserr) type(parse_state),intent(inout):: parser - integer,intent(in),optional:: method_name,param_base logical:: iserr type(pm_ptr),target::ptr,dom,dparams,rtypes type(pm_ptr):: p,params,link @@ -4552,52 +4415,60 @@ function proc_decl(parser,method_name,param_base) result(iserr) integer:: name,callname,this,thispar integer:: nret,base,flags,sbase,scount,m,nreduce,sym integer:: line,pos,nerrors - logical:: ampargs,iscall,iscomm,isshared,islocal,ischan,ismethod,have_rtn + logical:: ampargs,iscall,iscomm,isref,isshared,islocal,ischan,have_rtn nerrors=parser%error_count reg=>pm_register(parser%context,'proc',ptr,dom,dparams,rtypes) iserr=.true. - ismethod=present(method_name) sym=sym_proc nret=0 + flags=0 sbase=parser%vtop scount=parser%error_count dom=pm_null_obj dparams=pm_null_obj thispar=-1 - ! Procedure name - if(ismethod) then - name=method_name - else - call scan(parser) - if(.not.check_name(parser,name)) then - if(op(parser,name,.false.,.false.)) goto 999 - endif - endif - ! Line and position of procedure start call get_sym_pos(parser,line,pos) - - ! Communicating proc flag + call scan(parser) + + ! Reference procedure proc .name(...) iscomm=.false. - if(parser%sym==sym_pct) then + isref=.false. + if(parser%sym==sym_dot) then call scan(parser) + flags=ior(flags,proccall_is_ref+proccall_is_comm) iscomm=.true. + isref=.true. + endif + + ! Procedure name + if(.not.check_name(parser,name)) then + if(.not.isref) then + if(op(parser,name,.false.,.false.)) goto 999 + endif + endif + + ! Communicating proc flags + if(.not.isref) then + if(parser%sym==sym_pct) then + call scan(parser) + flags=ior(flags,proccall_is_comm) + iscomm=.true. + elseif(parser%sym==sym_dash) then + call scan(parser) + flags=ior(flags,proccall_is_comm+proccall_is_general) + iscomm=.true. + endif endif ! Start of parameters - if(.not.present(param_base)) then - if(expect(parser,sym_open)) goto 999 - endif + if(expect(parser,sym_open)) goto 999 10 continue ! Create fully qualified (module!name) procedure name - if(ismethod) then - call push_sym_val(parser,name) - else - call make_qualified_name(parser,name) - endif + call make_qualified_name(parser,name) ! Start of procedure delaration node base=parser%vtop @@ -4610,20 +4481,13 @@ function proc_decl(parser,method_name,param_base) result(iserr) ! Push some more entries in the procedure node (some get values later) call push_val(parser,parser%modl) call push_num_val(parser,-12345) ! flags - if(param_list(parser,iscomm,param_base)) goto 999 + if(param_list(parser,iscomm)) goto 999 + params=parser%vstack(parser%vtop-2) - call push_num_val(parser,-777) ! coded params call push_num_val(parser,-777) ! coded returns call push_num_val(parser,-777) ! coded type call push_num_val(parser,-777) ! nret - ! Start computing flags for this procedure node - if(iscomm) then - flags=proc_is_comm - else - flags=0 - endif - ! Return types ->(typelist) if(parser%sym==sym_arrow) then call scan(parser) @@ -4642,16 +4506,18 @@ function proc_decl(parser,method_name,param_base) result(iserr) call push_null_val(parser) nret=-1 endif - + + if(parser%sym==sym_yield) then + if(yield_clause()) return + endif + ! Special kinds of comm proc if(proc_comm_kinds(parser,flags)) goto 999 ! Attributes if(parser%sym==sym_open_attr) then if(proc_call_attr(parser,.false.,flags)) goto 999 - if(iand(flags,proc_is_each_proc)==0) then - call push_null_val(parser) - endif + call push_null_val(parser) else call push_null_val(parser) endif @@ -4663,13 +4529,28 @@ function proc_decl(parser,method_name,param_base) result(iserr) endif ! = expr or [ check expr ] block - if(parser%sym==sym_define.and.nret==-1) then + if(parser%sym==sym_assign.and.nret==-1) then call push_null_val(parser) call scan(parser) + m=0 do - if(expr(parser)) goto 999 + if(isref) then + if(m>0) then + call parse_error(parser,& + 'Cannot return more than one value from reference "." procedure') + if(expr(parser)) goto 999 + else + if(parser%sym>=sym_pm_dref.and.parser%sym<=sym_pm_ref) then + if(term(parser,.false.)) goto 999 + else + if(valref(parser)) goto 999 + endif + endif + else + if(expr(parser)) goto 999 + endif call push_null_val(parser) m=m+2 if(parser%sym/=sym_comma) exit @@ -4761,7 +4642,7 @@ function proc_decl(parser,method_name,param_base) result(iserr) call make_node_at(parser,sym,proc_num_args,line,pos) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'PROC DECL>----------------' call dump_parse_tree(parser%context,44,top_val(parser),2) write(*,*) 'PROC-DECL----------------' @@ -4775,6 +4656,66 @@ function proc_decl(parser,method_name,param_base) result(iserr) return contains include 'fisnull.inc' + include 'fesize.inc' + + function yield_clause() result(iserr) + logical:: iserr + integer:: m,n,i,k,base,first + type(pm_ptr):: params,amps + iserr=.true. + if(iand(flags,proccall_is_comm)/=0) then + first=num_comm_args+1 + else + first=2 + endif + params=parser%vstack(parser%vtop-7) + n=node_numargs(params)/2 + amps=parser%vstack(parser%vtop-5) + do i=1,first-1 + call push_val(parser,node_arg(params,i*2-1)) + call push_val(parser,node_arg(params,i*2)) + enddo + base=parser%top + m=first + call push_sym_val(parser,sym_block_proc) + call scan(parser) + call push_back(parser,sym_dash) + if(proctyp(parser,yield=.true.)) return + m=m+1 + call push_sym_val(parser,sym_block_inouts) + call push_null_val(parser) + call push_sym(parser,m) + m=m+1 + call push_sym_val(parser,sym_block_ins) + call push_null_val(parser) + m=m+1 + if(pm_fast_isnull(amps))then + do i=first,n + call push_val(parser,node_arg(params,i*2-1)) + call push_val(parser,node_arg(params,i*2)) + enddo + else + k=0 + do i=first,n + call push_val(parser,node_arg(params,i*2-1)) + call push_val(parser,node_arg(params,i*2)) + m=m+1 + if(amps%data%i(amps%offset+k)==i) then + call push_sym(parser,m) + k=min(k+1,pm_fast_esize(amps)) + endif + enddo + endif + call make_node(parser,node_sym(params),n*2+num_comm_args) + parser%vstack(parser%vtop-8)=top_val(parser) + call drop_val(parser) + + call name_vector(parser,base) + parser%vstack(parser%vtop-6)=top_val(parser) + call drop_val(parser) + + iserr=.false. + end function yield_clause function return_stmt() result(iserr) logical:: iserr @@ -4783,7 +4724,21 @@ function return_stmt() result(iserr) call scan(parser) m=0 do - if(expr(parser)) return + if(isref) then + if(m>0) then + call parse_error(parser,& + 'Cannot return more than one value from reference "." procedure') + if(expr(parser)) return + else + if(parser%sym>=sym_pm_dref.and.parser%sym<=sym_pm_ref) then + if(term(parser,.false.)) return + else + if(valref(parser)) return + endif + endif + else + if(expr(parser)) return + endif m=m+2 if(nret>=m/2.and..not.pm_fast_isnull(rtypes)) then call push_val(parser,node_arg(rtypes,m/2)) @@ -4817,23 +4772,18 @@ recursive function proc_sig(parser) result(iserr) type(pm_ptr):: temp base=parser%top iserr=.true. - m=0 + m=1 n=0 - if(parser%sym==sym_eq) then + call push_sym_val(parser,sym_topology) + if(parser%sym==sym_topology) then call scan(parser) - call make_node(parser,sym_eq,0) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else call push_null_val(parser) - if(parser%sym==sym_amp) then - call scan(parser) - parser%top=parser%top+1 - parser%stack(parser%top)=1 - call name_vector(parser,base) - else - call push_null_val(parser) - endif - if(expect(parser,sym_close)) return - elseif(parser%sym==sym_close) then - call make_node(parser,sym_list,0) + endif + if(parser%sym==sym_close) then + call make_node(parser,sym_list,2) call push_null_val(parser) call push_null_val(parser) call scan(parser) @@ -4846,7 +4796,7 @@ recursive function proc_sig(parser) result(iserr) parser%stack(parser%top)=m endif if(check_name(parser,name)) then - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call make_node(parser,sym_list,m*2) call push_sym_val(parser,name) call scan(parser) @@ -4860,17 +4810,13 @@ recursive function proc_sig(parser) result(iserr) call push_back_name(parser,name) call push_null_val(parser) endif - else if(parser%sym==sym_arg) then - call push_sym_val(parser,sym_arg) + else if(parser%sym==sym_dotdotdot) then + call push_sym_val(parser,sym_dotdotdot) call scan(parser) - if(expect(parser,sym_dotdotdot)) return if(expect(parser,sym_colon)) return if(moded_typ(parser,.true.,.false.)) return call make_node(parser,sym_dotdotdot,m*2) exit - else if(parser%sym==sym_key) then - call make_node(parser,sym_list,m*2) - exit else call push_null_val(parser) endif @@ -4890,18 +4836,13 @@ recursive function proc_sig(parser) result(iserr) enddo do while(parser%sym==sym_comma) call scan(parser) - if(parser%sym==sym_key) exit if(typ(parser)) return if(expect_name(parser,& 'optional parameter name')) return - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return n=n+1 enddo - if(parser%sym==sym_key) then - call make_node(parser,sym_dotdotdot,n*2) - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - else if(n>0) then + if(n>0) then call make_node(parser,sym_list,n*2) else call push_null_val(parser) @@ -4934,9 +4875,9 @@ recursive function proc_sig(parser) result(iserr) call push_null_val(parser) call push_val(parser,parser%temp) call make_node(parser,sym,1) - case(sym_pct,sym_define,sym_dot,sym_query,sym_amp,& + case(sym_pct,sym_assign,sym_dot,sym_query,sym_amp,& sym_hash,sym_caret,sym_dcaret,sym_d1:sym_d7,sym_invar,sym_shared,& - sym_type,sym_tilde,sym_damp,sym_bar) + sym_type,sym_tilde,sym_bar) ! These return N types based on types of a ! list of N expressions call scan(parser) @@ -4950,11 +4891,11 @@ recursive function proc_sig(parser) result(iserr) call push_null_val(parser) call push_val(parser,parser%temp) call make_node(parser,sym,1) - case(sym_dash) + case(sym_dcolon) call scan(parser) if(typ_list(parser,m)) return call make_node(parser,sym_result,m) - call make_node(parser,sym_dash,1) + call make_node(parser,sym_dcolon,1) call push_num_val(parser,m) call swap_vals(parser) call push_null_val(parser) @@ -5013,7 +4954,7 @@ function builtin_flags(parser,flags) result(iserr) end function builtin_flags !====================================================== - ! Built in procedure definition + ! Intrinsic procedure definition !====================================================== function intrinsic(parser) result(iserr) type(parse_state),intent(inout):: parser @@ -5027,6 +4968,11 @@ function intrinsic(parser) result(iserr) call scan(parser) if(builtin_flags(parser,flags)) goto 999 + + if(parser%sym==sym_dot) then + call scan(parser) + flags=ior(flags,proccall_is_comm+proccall_is_ref) + endif if(.not.check_name(parser,name)) then if(op(parser,name,.false.,.false.)) goto 999 @@ -5034,9 +4980,15 @@ function intrinsic(parser) result(iserr) else call push_sym_val(parser,name) endif - if(parser%sym==sym_pct) then - call scan(parser) - flags=ior(flags,call_is_comm) + + if(iand(flags,proccall_is_ref)==0) then + if(parser%sym==sym_pct) then + call scan(parser) + flags=ior(flags,proccall_is_comm) + elseif(parser%sym==sym_dash) then + call scan(parser) + flags=ior(flags,proccall_is_comm+proccall_is_general) + endif endif ! Create full name: module!name @@ -5079,7 +5031,7 @@ function intrinsic(parser) result(iserr) call push_val(parser,pm_null_obj) call push_null_val(parser) call make_node(parser,sym_builtin,sysproc_num_args) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'BUILTIN DECL>----------------' call dump_parse_tree(parser%context,6,top_val(parser),2) write(*,*) 'BI-DECL-------------' @@ -5115,7 +5067,7 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) endif if(parser%sym==sym_pct) then call scan(parser) - flags=ior(pflags,call_is_comm) + flags=ior(pflags,proccall_is_comm) else flags=pflags endif @@ -5141,7 +5093,7 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) call push_val(parser,pdata) call push_null_val(parser) call make_node(parser,sym_builtin,sysproc_num_args) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'BUILTIN DECL>----------------' call dump_parse_tree(parser%context,6,top_val(parser),2) write(*,*) 'BI-DECL-------------' @@ -5270,7 +5222,7 @@ function typ_decl(parser) result(iserr) endif 10 continue call make_node(parser,sym,type_num_args+nextra) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'TYPEDECL>----------------' call dump_parse_tree(parser%context,6,top_val(parser),2) write(*,*) 'END TYPEDECL-------------' @@ -5502,12 +5454,6 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) 'Expected name of '//sym_names(sym)//' element') return endif - elseif(parser%sym==sym_proc) then - if(method(parser,typname,params,base)) return - n=n+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - cycle elseif(check_name_no_repeat(parser,name,base+1)) then call push_sym(parser,name) else @@ -5522,10 +5468,10 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) else call push_null_val(parser) endif - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call scan(parser) if(expr(parser)) return - call make_node(parser,sym_define,2) + call make_node(parser,sym_assign,2) endif if(parser%sym/=sym_comma) exit call scan(parser) @@ -5548,50 +5494,6 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) include 'fisnull.inc' end function structrec - !====================================================== - ! Method definition proc name(...) { ... } - ! in struct, rec - !====================================================== - recursive function method(parser,typname,params,base) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(in):: typname,base - type(pm_ptr),intent(in):: params - logical:: iserr - type(pm_ptr):: p - integer:: mname,name,tname,pbase - logical:: iscomm - iserr=.true. - call scan(parser) - if(check_name_no_repeat(parser,name,base+1)) then - p=parser%modl%data%ptr(parser%modl%offset+modl_name) - mname=-p%offset - call push_sym(parser,mname) - call push_sym(parser,typname) - call push_sym(parser,name) - call name_vector(parser,parser%top-3) - tname=parser%vstack(parser%vtop)%offset - parser%vtop=parser%vtop-1 - pbase=parser%top - iscomm=parser%sym==sym_pct - if(proctyp(parser,typname,params,.true.)) return - if(iscomm) call push_back(parser,sym_pct) - if(parser%sym/=sym_open_brace.and.parser%sym/=sym_colon) then - if(expect(parser,sym_open_brace)) return - endif - if(proc_decl(parser,tname,pbase)) return - call push_sym_val(parser,tname) - call make_node(parser,sym_proc,1) - call make_node(parser,sym_define,2) - parser%top=pbase - call push_sym(parser,name) - else - call parse_error(parser,'Expected method name') - return - endif - iserr=.false. - end function method - - !====================================================== ! Parameter declarations !====================================================== @@ -5604,7 +5506,7 @@ function param_decl(parser) result(iserr) do call push_null_val(parser) if(.not.check_name(parser,name)) return - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return serror=parser%error_count call xexpr(parser) if(parser%error_count>serror) return @@ -5861,7 +5763,7 @@ end subroutine decl recursive subroutine skip_past_error(parser,expr) type(parse_state),intent(inout):: parser logical,intent(in):: expr - if(debug_parser_extra) write(*,*) 'Skipping',expr + if(debug_parser) write(*,*) 'Skipping',expr do if(expr) then if(parser%sym<=num_sym.and.parser%sym>last_expr) then @@ -5870,7 +5772,7 @@ recursive subroutine skip_past_error(parser,expr) endif do while(parser%sym/=sym_eof.and.(parser%sym>num_sym.or.& parser%sym<=last_expr)) - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call push_back(parser,sym_array) exit endif @@ -5892,7 +5794,7 @@ recursive subroutine skip_past_error(parser,expr) exit endif enddo - if(debug_parser_extra) write(*,*) 'Skipped' + if(debug_parser) write(*,*) 'Skipped' end subroutine skip_past_error !====================================================== @@ -6117,7 +6019,7 @@ subroutine make_node_at(parser,typeno,n,line,pos) val=pm_fast_newnc(parser%context,pm_pointer,n+5) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'make node:',sym_names(typeno),& parser%vtop,n,val%data%esize endif @@ -6147,7 +6049,7 @@ subroutine make_node_at(parser,typeno,n,line,pos) parser%vstack(parser%vtop)=val parser%vline(parser%vtop)=line parser%vchar(parser%vtop)=pos - if(debug_parser_extra) then + if(debug_parser) then write(*,*) '------New node------',n+5 call dump_parse_tree(parser%context,6,val,2) write(*,*) '--------------------' @@ -6367,7 +6269,7 @@ subroutine parse_error(parser,emess) character(len=7):: lbuffer,lbuffer2 integer:: i,n if(pm_main_process) then - if(debug_parser_extra) write(*,*) '*****Error::',trim(emess) + if(debug_parser) write(*,*) '*****Error::',trim(emess) call pm_name_string(parser%context,& int(parser%modl%data%ptr(parser%modl%offset+modl_name)%offset),modname) write(lbuffer,'(I7)') parser%sym_lineno diff --git a/src/symbol.f90 b/src/symbol.f90 index fa7aa75..0ec6c95 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -54,38 +54,37 @@ module pm_symbol integer,parameter:: sym_ddollar = 10 integer,parameter:: sym_comma = 11 integer,parameter:: sym_dot = 12 - integer,parameter:: sym_assign = 13 - integer,parameter:: sym_underscore = 14 - integer,parameter:: sym_open_attr = 15 - integer,parameter:: sym_close_attr = 16 - integer,parameter:: sym_query = 17 - integer,parameter:: sym_arrow = 18 - integer,parameter:: sym_pct = 19 - integer,parameter:: sym_pling = 20 - integer,parameter:: sym_dash = 21 - integer,parameter:: sym_caret = 22 - integer,parameter:: sym_dcaret = 23 - integer,parameter:: sym_dcolon = 24 - integer,parameter:: sym_damp = 25 - integer,parameter:: sym_define = 26 - integer,parameter:: sym_cond = 27 - integer,parameter:: sym_string = 28 - integer,parameter:: sym_number = 29 + integer,parameter:: sym_underscore = 13 + integer,parameter:: sym_open_attr = 14 + integer,parameter:: sym_close_attr = 15 + integer,parameter:: sym_query = 16 + integer,parameter:: sym_arrow = 17 + integer,parameter:: sym_pct = 18 + integer,parameter:: sym_pling = 19 + integer,parameter:: sym_dash = 20 + integer,parameter:: sym_caret = 21 + integer,parameter:: sym_dcaret = 22 + integer,parameter:: sym_dcolon = 23 + integer,parameter:: sym_assign = 24 + integer,parameter:: sym_cond = 25 + integer,parameter:: sym_string = 26 + integer,parameter:: sym_number = 27 ! Operators integer,parameter:: sym1 = sym_number integer,parameter:: sym_open = sym1 + 1 integer,parameter:: sym_close = sym1 + 2 - integer,parameter:: sym_le = sym1 + 3 - integer,parameter:: sym_lt = sym1 + 4 - integer,parameter:: sym_ustar = sym1 + 5 - integer,parameter:: sym_uhash = sym1 + 6 + integer,parameter:: sym_open_smiley = sym1 + 3 + integer,parameter:: sym_close_smiley = sym1 + 4 + integer,parameter:: sym_le = sym1 + 5 + integer,parameter:: sym_lt = sym1 + 6 + integer,parameter:: sym_ustar = sym1 + 7 + integer,parameter:: sym_uhash = sym1 + 8 + + integer,parameter:: sym2 = sym_uhash - integer,parameter:: sym_from_range = sym1 + 7 - integer,parameter:: first_operator = sym_from_range - integer,parameter:: sym_to_range = sym1 + 8 - integer,parameter:: sym2 = sym_to_range integer,parameter:: sym_concat = sym2 + 1 + integer,parameter:: first_operator = sym_concat integer,parameter:: sym_eq = sym2 + 2 integer,parameter:: sym_ne = sym2 + 3 integer,parameter:: sym_ge = sym2 + 4 @@ -107,56 +106,46 @@ module pm_symbol integer,parameter:: sym_not_in = first_key + 2 integer,parameter:: sym_and = first_key + 3 integer,parameter:: sym_or = first_key + 4 - integer,parameter:: sym_xor = first_key + 5 - integer,parameter:: sym_shift = first_key + 6 - integer,parameter:: sym_fmt = first_key + 7 - integer,parameter:: sym_by = first_key + 8 - integer,parameter:: sym_mod = first_key + 9 - integer,parameter:: sym_div = first_key + 10 - integer,parameter:: sym_except = first_key + 11 - integer,parameter:: sym_includes = first_key + 12 - integer,parameter:: sym_not_includes = first_key + 13 - integer,parameter:: sym_ortho = first_key + 14 - integer,parameter:: sym_is = first_key + 15 - integer,parameter:: sym_is_not = first_key + 16 - integer,parameter:: sym_as = first_key + 17 + integer,parameter:: sym_shift = first_key + 5 + integer,parameter:: sym_fmt = first_key + 6 + integer,parameter:: sym_by = first_key + 7 + integer,parameter:: sym_mod = first_key + 8 + integer,parameter:: sym_div = first_key + 9 + integer,parameter:: sym_except = first_key + 10 + integer,parameter:: sym_includes = first_key + 11 + integer,parameter:: sym_not_includes = first_key + 12 + integer,parameter:: sym_ortho = first_key + 13 + integer,parameter:: sym_is = first_key + 14 + integer,parameter:: sym_is_not = first_key + 15 + integer,parameter:: sym_as = first_key + 16 ! Unary operators - integer,parameter:: sym_not = first_key + 18 + integer,parameter:: sym_not = first_key + 17 integer,parameter:: last_operator = sym_not ! Statement / expression general keywords integer,parameter:: sym_null = last_operator + 1 - integer,parameter:: sym_key = last_operator + 2 - integer,parameter:: sym_arg = last_operator + 3 - integer,parameter:: sym_true = last_operator + 4 - integer,parameter:: sym_false = last_operator + 5 - integer,parameter:: sym_struct = last_operator + 6 - integer,parameter:: sym_rec = last_operator + 7 - integer,parameter:: sym_any = last_operator + 8 - integer,parameter:: sym_present = last_operator + 9 - integer,parameter:: sym_unique = last_operator + 10 - integer,parameter:: sym_fix = last_operator + 11 - integer,parameter:: sym_new = last_operator + 12 - integer,parameter:: sym_of = last_operator + 13 - integer,parameter:: sym_bounds = last_operator + 14 - integer,parameter:: last_expr = sym_bounds + integer,parameter:: sym_true = last_operator + 2 + integer,parameter:: sym_false = last_operator + 3 + integer,parameter:: sym_struct = last_operator + 4 + integer,parameter:: sym_rec = last_operator + 5 + integer,parameter:: sym_any = last_operator + 6 + integer,parameter:: sym_present = last_operator + 7 + integer,parameter:: sym_unique = last_operator + 8 + integer,parameter:: sym_fix = last_operator + 9 + integer,parameter:: sym_new = last_operator + 10 + integer,parameter:: sym_when = last_operator + 11 + integer,parameter:: last_expr = sym_when integer,parameter:: last_word = last_expr ! Modes - - integer,parameter:: sym_private = last_word + 1 integer,parameter:: first_mode = sym_private - integer,parameter:: sym_invar = last_word + 2 - integer,parameter:: sym_complete = last_word + 3 - integer,parameter:: sym_universal= last_word + 4 - integer,parameter:: sym_local = last_word + 5 - integer,parameter:: sym_partial = last_word + 6 - integer,parameter:: sym_coherent = last_word + 7 - integer,parameter:: sym_chan = last_word + 8 - integer,parameter:: sym_mirrored = last_word + 9 - integer,parameter:: sym_shared = last_word + 10 + integer,parameter:: sym_chan = last_word + 2 + integer,parameter:: sym_local = last_word + 3 + integer,parameter:: sym_joint = last_word + 4 + integer,parameter:: sym_invar = last_word + 5 + integer,parameter:: sym_shared = last_word + 6 integer,parameter:: last_mode = sym_shared integer,parameter:: last_key = sym_shared @@ -189,7 +178,7 @@ module pm_symbol integer,parameter:: sym_return = last_decl + 14 integer,parameter:: sym_also = last_decl + 15 integer,parameter:: sym_do = last_decl + 16 - integer,parameter:: sym_nhd = last_decl + 17 + integer,parameter:: sym_yield = last_decl + 17 integer,parameter:: sym_test = last_decl + 18 integer,parameter:: sym_default = last_decl + 19 integer,parameter:: sym_task = last_decl + 20 @@ -226,13 +215,15 @@ module pm_symbol integer,parameter:: sym_pm_dref_shared_slice = last_resv + 11 integer,parameter:: sym_pm_dref_here = last_resv + 12 integer,parameter:: sym_pm_ref = last_resv + 13 - integer,parameter:: sym_pm_head_node = last_resv + 14 - integer,parameter:: sym_pm_do_at = last_resv + 15 - integer,parameter:: sym_pm_do = last_resv + 16 - integer,parameter:: sym_pm_intrinsic = last_resv + 17 - integer,parameter:: sym_pm_if_compiling = last_resv + 18 - integer,parameter:: sym_pm_else = last_resv + 19 - integer,parameter:: sym_pm_endif = last_resv + 20 + integer,parameter:: sym_pm_dref_any = last_resv + 14 + integer,parameter:: sym_pm_dref_any_slice = last_resv + 15 + integer,parameter:: sym_pm_head_node = last_resv + 16 + integer,parameter:: sym_pm_do_at = last_resv + 17 + integer,parameter:: sym_pm_do = last_resv + 18 + integer,parameter:: sym_pm_intrinsic = last_resv + 19 + integer,parameter:: sym_pm_if_compiling = last_resv + 20 + integer,parameter:: sym_pm_else = last_resv + 21 + integer,parameter:: sym_pm_endif = last_resv + 22 integer,parameter:: last_stmt = sym_pm_endif integer,parameter:: num_sym = last_stmt @@ -324,9 +315,11 @@ module pm_symbol integer,parameter:: sym_nested_loop = node0 + 45 integer,parameter:: sym_assign_list = node0 + 46 integer,parameter:: sym_case_range = node0 + 47 + integer,parameter:: sym_dot_call = node0 + 48 + integer,parameter:: sym_key = node0 + 49 ! Misc. other symbols that need to be referenced by the compiler - integer,parameter:: hook = node0 + 48 + integer,parameter:: hook = node0 + 50 integer,parameter:: sym_pval_as = hook integer,parameter:: sym_pm_system = hook+1 integer,parameter:: sym_get_element = hook+2 @@ -354,7 +347,14 @@ module pm_symbol integer,parameter:: sym_invar_dim = hook + 24 integer,parameter:: sym_fix_dim = hook + 25 integer,parameter:: sym_sync_messages = hook + 26 - integer,parameter:: hook1 = hook + 26 + integer,parameter:: sym_block_inouts=hook + 27 + integer,parameter:: sym_block_ins=hook + 28 + integer,parameter:: sym_block_proc=hook + 29 + integer,parameter:: sym_block_inouts_a=hook + 30 + integer,parameter:: sym_block_ins_a=hook + 31 + integer,parameter:: sym_block_proc_a=hook + 32 + integer,parameter:: sym_elem_at_index=hook + 33 + integer,parameter:: hook1 = hook + 33 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -416,24 +416,26 @@ module pm_symbol integer,parameter:: sym_shared_to_local = hook4 + 3 integer,parameter:: sym_clone = hook4 + 4 integer,parameter:: sym_contains = hook4 + 5 - integer,parameter:: sym_this = hook4 + 6 + integer,parameter:: sym_mask = hook4 + 6 integer,parameter:: sym_here = hook4 + 7 integer,parameter:: sym_here_in_tile = hook4 + 8 integer,parameter:: sym_subregion = hook4 + 9 integer,parameter:: sym_region = hook4 + 10 - integer,parameter:: sym_distr_tag = hook4 + 11 - integer,parameter:: sym_tag = hook4 + 12 - integer,parameter:: sym_varray= hook4 + 13 - integer,parameter:: sym_map_array= hook4 + 14 - integer,parameter:: sym_map_varray= hook4 + 15 - integer,parameter:: sym_get_val_ref = hook4 + 16 - integer,parameter:: sym_local_distr = hook4 + 17 - integer,parameter:: sym_pm_chan = hook4 + 18 - integer,parameter:: sym_get_chan = hook4 + 19 - integer,parameter:: sym_pm_local = hook4 + 20 - integer,parameter:: sym_casts_to = hook4 + 21 - integer,parameter:: sym_combine_indices = hook4 + 22 - integer,parameter:: hook5 = hook4 + 22 + integer,parameter:: sym_outer = hook4 + 11 + integer,parameter:: sym_topology = hook4 + 12 + integer,parameter:: sym_distr_tag = hook4 + 13 + integer,parameter:: sym_tag = hook4 + 14 + integer,parameter:: sym_varray= hook4 + 15 + integer,parameter:: sym_map_array= hook4 + 16 + integer,parameter:: sym_map_varray= hook4 + 17 + integer,parameter:: sym_get_val_ref = hook4 + 18 + integer,parameter:: sym_local_distr = hook4 + 19 + integer,parameter:: sym_pm_chan = hook4 + 20 + integer,parameter:: sym_get_chan = hook4 + 21 + integer,parameter:: sym_pm_local = hook4 + 22 + integer,parameter:: sym_casts_to = hook4 + 23 + integer,parameter:: sym_combine_indices = hook4 + 24 + integer,parameter:: hook5 = hook4 + 24 integer,parameter:: sym_pm_ref_type = hook5 + 1 integer,parameter:: sym_pling_local = hook5 + 2 @@ -500,7 +502,6 @@ module pm_symbol data sym_names(sym_ddollar) /'$$'/ data sym_names(sym_comma) /','/ data sym_names(sym_dot) /'.'/ - data sym_names(sym_assign) /':='/ data sym_names(sym_underscore) /'_'/ data sym_names(sym_open_attr) /'<<'/ data sym_names(sym_close_attr) /'>>'/ @@ -512,8 +513,7 @@ module pm_symbol data sym_names(sym_caret) /'^'/ data sym_names(sym_dcaret) /'^^'/ data sym_names(sym_dcolon) /'::'/ - data sym_names(sym_damp) /'&&'/ - data sym_names(sym_define) /'='/ + data sym_names(sym_assign) /'='/ data sym_names(sym_cond) /'=>'/ data sym_names(sym_string) /''/ @@ -522,13 +522,12 @@ module pm_symbol ! Operators data sym_names(sym_open) /'('/ data sym_names(sym_close) /')'/ + data sym_names(sym_open_smiley) /'(:'/ + data sym_names(sym_close_smiley) /':)'/ data sym_names(sym_le) /'<='/ data sym_names(sym_lt) /'<'/ data sym_names(sym_ustar) /'unary *'/ - - data sym_names(sym_from_range) /'_...'/ - data sym_names(sym_to_range) /'..._'/ data sym_names(sym_concat) /'++'/ data sym_names(sym_eq) /'=='/ data sym_names(sym_ne) /'/='/ @@ -549,7 +548,6 @@ module pm_symbol data sym_names(sym_not_in) /'notin'/ data sym_names(sym_and) /'and'/ data sym_names(sym_or) /'or'/ - data sym_names(sym_xor) /'xor'/ data sym_names(sym_shift) /'shift'/ data sym_names(sym_fmt) /'fmt'/ data sym_names(sym_by) /'by'/ @@ -566,8 +564,6 @@ module pm_symbol ! Statement / expression general keywords data sym_names(sym_null) /'null'/ - data sym_names(sym_key) /'key'/ - data sym_names(sym_arg) /'arg'/ data sym_names(sym_true) /'true'/ data sym_names(sym_false) /'false'/ data sym_names(sym_struct) /'struct'/ @@ -577,20 +573,14 @@ module pm_symbol data sym_names(sym_unique) /'unique'/ data sym_names(sym_fix) /'fix'/ data sym_names(sym_new) /'new'/ - data sym_names(sym_bounds) /'bounds'/ - data sym_names(sym_of) /'of'/ + data sym_names(sym_when) /'when'/ data sym_names(sym_private) /'priv'/ - data sym_names(sym_invar) /'invar'/ - data sym_names(sym_complete) /'complete'/ - data sym_names(sym_universal) /'universal'/ - data sym_names(sym_local) /'local'/ - - data sym_names(sym_partial) /'partial'/ - data sym_names(sym_coherent) /'coherent'/ data sym_names(sym_chan) /'chan'/ - data sym_names(sym_mirrored) /'uniform'/ - data sym_names(sym_shared) /'shared'/ + data sym_names(sym_local) /'lcl'/ + data sym_names(sym_joint) /'jnt'/ + data sym_names(sym_invar) /'invar'/ + data sym_names(sym_shared) /'shrd'/ ! Declaration keywords data sym_names(sym_package) /'package'/ @@ -617,7 +607,7 @@ module pm_symbol data sym_names(sym_while) /'while'/ data sym_names(sym_return) /'return'/ data sym_names(sym_do) /'do'/ - data sym_names(sym_nhd) /'nhd'/ + data sym_names(sym_yield) /'yield'/ data sym_names(sym_test) /'test'/ data sym_names(sym_default) /'default'/ data sym_names(sym_task) /'task'/ @@ -651,6 +641,8 @@ module pm_symbol data sym_names(sym_pm_dref_shared_slice) /'PM__dref_is'/ data sym_names(sym_pm_dref_here) /'PM__drefhere'/ data sym_names(sym_pm_ref) /'PM__ref'/ + data sym_names(sym_pm_dref_any) /'PM__anyref'/ + data sym_names(sym_pm_dref_any_slice) /'PM__anyref_s'/ data sym_names(sym_pm_head_node) /'PM__head_node'/ data sym_names(sym_pm_do_at) /'PM__do_at'/ data sym_names(sym_pm_do) /'PM__do'/ @@ -743,6 +735,8 @@ module pm_symbol data sym_names(sym_nested_loop) /'PM__nested_loop'/ data sym_names(sym_assign_list) /''/ data sym_names(sym_case_range) /'PM__caserange'/ + data sym_names(sym_dot_call) /''/ + data sym_names(sym_key) /''/ ! Misc. symbols referenced by compiler @@ -772,6 +766,14 @@ module pm_symbol data sym_names(sym_invar_dim) /'PM__invar_dim'/ data sym_names(sym_fix_dim) /'PM__fix_dim'/ data sym_names(sym_sync_messages) /'PM__sync_messages'/ + data sym_names(sym_block_inouts) /'PM__inouts'/ + data sym_names(sym_block_ins) /'PM__ins'/ + data sym_names(sym_block_proc) /'PM__block_proc'/ + data sym_names(sym_block_inouts_a) /'PM__inouts_a'/ + data sym_names(sym_block_ins_a) /'PM__ins_a'/ + data sym_names(sym_block_proc_a) /'PM__block_proc_a'/ + data sym_names(sym_elem_at_index) /'element_at_index'/ + data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ @@ -832,11 +834,13 @@ module pm_symbol data sym_names(sym_shared_to_local) /'PM__shared_to_local'/ data sym_names(sym_clone) /'PM__clone'/ data sym_names(sym_contains) /'contains'/ - data sym_names(sym_this) /'this'/ - data sym_names(sym_here) /'here'/ - data sym_names(sym_here_in_tile) /'here_in_tile'/ - data sym_names(sym_subregion) /'schedule'/ - data sym_names(sym_region) /'region'/ + data sym_names(sym_mask) /'PM__mask'/ + data sym_names(sym_here) /'PM__here'/ + data sym_names(sym_here_in_tile) /'PM__here_in_tile'/ + data sym_names(sym_subregion) /'PM__schedule'/ + data sym_names(sym_region) /'PM__region'/ + data sym_names(sym_outer) /'PM__outer'/ + data sym_names(sym_topology) /'PM__topology'/ data sym_names(sym_distr_tag) /'PM__distr_tag'/ data sym_names(sym_tag) /'PM__tag'/ data sym_names(sym_varray) /'PM__varray'/ @@ -1161,7 +1165,7 @@ recursive subroutine pm_name_string(context,m,str) if(pm_fast_esize(ptr)>1) then do i=2,pm_fast_esize(ptr) call pm_name_string(context,ptr%data%i(ptr%offset+i),str2) - str=trim(str)//''''//str2 + str=trim(str)//'::'//str2 enddo endif else @@ -1169,7 +1173,7 @@ recursive subroutine pm_name_string(context,m,str) -first,str) call pm_name_string(context,& second,str2) - str=trim(str)//''''//str2 + str=trim(str)//'::'//str2 endif else if(pm_fast_esize(ptr)==1.and.ptr%data%i(ptr%offset)==sym_pm_system) then @@ -1182,7 +1186,7 @@ recursive subroutine pm_name_string(context,m,str) if(i==0) then str=trim(str2) else - str=trim(str)//''''//trim(str2) + str=trim(str)//'::'//trim(str2) endif enddo endif diff --git a/src/types.f90 b/src/types.f90 index 4b83bff..2a661d2 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -49,6 +49,10 @@ module pm_types integer,parameter:: pm_type_is_seq=32768 integer,parameter:: pm_type_leaves=65536 + integer,parameter:: pm_type_is_when=8192 + integer,parameter:: pm_type_is_yield=16384 + integer,parameter:: pm_type_is_list=32768 + ! Bitwise-or of flags which are not taints (only one so far) integer,parameter:: pm_type_flags_untainting = pm_type_has_embedded @@ -189,7 +193,6 @@ module pm_types integer,public,parameter:: pm_string_literal_type = pm_last_category_type + 4 integer,public,parameter:: pm_last_literal_type = pm_string_literal_type - ! Kind of dref type (internal type describing references) integer,public,parameter:: pm_dref_is_dot=0 @@ -714,6 +717,30 @@ function pm_type_name(context,tno) result(name) name=pm_tv_name(tv) end function pm_type_name + !===================================================== + ! Is type tuple with when? + !==============================---=================== + function pm_type_has_when(context,tno) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno + logical:: ok + type(pm_ptr):: tv + tv=pm_type_vect(context,tno) + ok=iand(pm_tv_flags(tv),pm_type_is_when)/=0 + end function pm_type_has_when + + !===================================================== + ! Return amp locs for tuple type + !==============================---=================== + function pm_type_amp(context,tno) result(amp) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: amp + type(pm_ptr):: tv + tv=pm_type_vect(context,tno) + amp=pm_tv_name(tv) + end function pm_type_amp + !===================================================== ! Return name of element #n associated with type tno !==============================---=================== @@ -880,14 +907,14 @@ function pm_type_get_mode(context,typ) result(mode) integer:: tk type(pm_ptr):: tv if(typ<=0) then - mode=sym_mirrored + mode=sym_invar return endif tv=pm_type_vect(context,typ) if(pm_tv_kind(tv)==pm_type_is_par_kind) then mode=iand(pm_tv_name(tv),mode_mask) else - mode=sym_coherent + mode=sym_private endif end function pm_type_get_mode @@ -903,7 +930,7 @@ function pm_type_strip_mode(context,typ,mode) result(typ2) type(pm_ptr):: tv if(typ<=0) then typ2=typ - mode=merge(sym_coherent,sym_mirrored,typ==0) + mode=merge(sym_private,sym_invar,typ==0) return endif tv=pm_type_vect(context,typ) @@ -911,49 +938,18 @@ function pm_type_strip_mode(context,typ,mode) result(typ2) mode=iand(pm_tv_name(tv),mode_mask) typ2=pm_tv_arg(tv,1) else - mode=sym_coherent + mode=sym_private typ2=typ endif end function pm_type_strip_mode - !========================================================================== - ! Strip mode information, mode, from type typ yielding unmoded type typ2 - ! Return in cond whether mode indicates a conditional context - !========================================================================== - function pm_type_strip_mode_and_cond(context,typ,mode,cond) result(typ2) - type(pm_context),pointer:: context - integer,intent(in):: typ - integer,intent(out):: mode - logical,intent(out):: cond - integer:: typ2 - integer:: tk - type(pm_ptr):: tv - if(typ<=0) then - typ2=typ - mode=merge(sym_coherent,sym_mirrored,typ==0) - cond=.false. - return - endif - tv=pm_type_vect(context,typ) - if(pm_tv_kind(tv)==pm_type_is_par_kind) then - mode=pm_tv_name(tv) - typ2=pm_tv_arg(tv,1) - cond=mode==sym_partial - else - mode=sym_coherent - typ2=typ - cond=.false. - endif - end function pm_type_strip_mode_and_cond - !============================================= ! Add mode information to an unmoded type !============================================= - function pm_type_add_mode(context,typ,mode,iscond,istyp) result(typ2) + function pm_type_add_mode(context,typ,mode,istype) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ,mode - logical,intent(in):: iscond - logical,intent(in),optional:: istyp + logical,intent(in),optional:: istype integer:: typ2,mode2,typ3 integer:: array(3) if(typ<0) then @@ -961,28 +957,28 @@ function pm_type_add_mode(context,typ,mode,iscond,istyp) result(typ2) return endif typ3=pm_type_strip_mode(context,typ,mode2) - if(mode2/=sym_coherent) then - write(*,*) trim(sym_names(mode2)) - call pm_panic('add-mode to moded type') + if(pm_debug_checks) then + if(mode2/=sym_private) then + write(*,*) trim(sym_names(mode2)) + call pm_panic('add-mode to moded type') + endif endif - if(mode==sym_coherent.and..not.(iscond.or.present(istyp))) then + if(mode==sym_private.and..not.present(istype)) then typ2=typ else array(1)=pm_type_new_par_kind - array(2)=merge(sym_partial,mode,iscond) + array(2)=mode array(3)=typ typ2=pm_new_type(context,array) endif end function pm_type_add_mode - !======================================================== ! Replace mode information in a (possibly) moded type !======================================================== - function pm_type_replace_mode(context,typ1,mode,iscond) result(typ2) + function pm_type_replace_mode(context,typ1,mode) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ1,mode - logical,intent(in):: iscond integer:: typ2 integer:: array(3),typ type(pm_ptr):: tv @@ -997,11 +993,11 @@ function pm_type_replace_mode(context,typ1,mode,iscond) result(typ2) else typ=typ1 endif - if(mode==sym_coherent.and..not.iscond) then + if(mode==sym_private) then typ2=typ else array(1)=pm_type_new_par_kind - array(2)=merge(sym_partial,mode,iscond) + array(2)=mode array(3)=typ typ2=pm_new_type(context,array) endif @@ -1022,7 +1018,7 @@ function pm_type_combine_modes(context,array,shared_ok) result(combined_mode) logical,intent(in):: shared_ok integer:: combined_mode integer:: i,mode,cmode,tno - cmode=sym_mirrored + cmode=sym_invar do i=1,size(array) tno=pm_type_strip_mode(context,array(i),mode) if(mode==sym_shared.and..not.shared_ok) then @@ -1033,31 +1029,43 @@ function pm_type_combine_modes(context,array,shared_ok) result(combined_mode) endif cmode=min(cmode,mode) enddo - if(cmode==sym_chan) cmode=sym_coherent + if(cmode==sym_chan) cmode=sym_private combined_mode=cmode end function pm_type_combine_modes + !===================================================================== + ! Rules for mixing modes in a list or reference + !===================================================================== + function pm_type_mix_modes(context,array) result(mixed_mode) + type(pm_context),pointer:: context + integer,intent(in),dimension(:):: array + integer:: mixed_mode + integer:: i,mode,cmax,cmin,tno + cmax=sym_private + cmin=sym_shared + do i=1,size(array) + tno=pm_type_strip_mode(context,array(i),mode) + cmin=min(cmin,mode) + cmax=max(cmax,mode) + enddo + if(cmin>sym_joint) then + mixed_mode=cmin + elseif(cmax>=sym_joint) then + mixed_mode=sym_joint + elseif(cmin==sym_local) then + mixed_mode=sym_local + else + mixed_mode=sym_private + endif + end function pm_type_mix_modes + !=================================== ! Does mode1 include mode2 ? !=================================== function pm_mode_includes(mode1,mode2) result(ok) integer,intent(in):: mode1,mode2 logical:: ok - if(mode1==mode2) then - ok=.true. - elseif(mode1==sym_private) then - ok=mode2>=sym_partial.and.mode2=sym_mirrored - elseif(mode1==sym_complete) then - ok=mode2>sym_partial.and.mode2=sym_mirrored) mode3=mode2 - if(iscond) mode3=-2 - case(sym_complete) - mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - case(sym_partial) - mode3=mode1 - case(sym_coherent) - mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - case(sym_mirrored) - if(mode2>=sym_mirrored) mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - case(sym_shared) - if(mode2>=sym_mirrored) mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - end select - endif - end function pm_type_convert_mode - !========================================================== ! Remove both mode information and internal vector type !========================================================== @@ -1536,6 +1505,12 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=.false. elseif(pm_tv_name(t)/=pm_tv_name(u)) then ok=.false. + elseif(iand(pm_tv_flags(t),pm_type_is_when)/=0.and.iand(pm_tv_flags(u),pm_type_is_when)==0) then + !( when) does not include ( ) + ok=.false. + elseif(iand(pm_tv_flags(t),pm_type_is_yield+pm_type_is_list)/=& + iand(pm_tv_flags(u),pm_type_is_yield+pm_type_is_list)) then + ok=.false. else nt=pm_tv_numargs(t) nu=pm_tv_numargs(u) @@ -1685,7 +1660,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_par_kind) ! Most cases catered for by uk switch - remaining case ok=iand(mode,pm_type_incl_val)/=0.and.& - pm_mode_includes(pm_tv_name(t),sym_coherent).and.& + pm_mode_includes(pm_tv_name(t),sym_private).and.& pm_test_type_includes(context,pm_tv_arg(t,1),q,& mode,einfo,params,base,user,ubase) case(pm_type_is_undef_result) @@ -2151,7 +2126,7 @@ recursive function pm_type_find_elem(context,tno,name,change,& endif call push(pm_type_new_dref) call push(name) - call push(pm_type_add_mode(context,etype,mode,.false.)) + call push(pm_type_add_mode(context,etype,mode)) call push(tno) do i=3,pm_tv_numargs(tv) call push(pm_tv_arg(tv,i)) @@ -2625,12 +2600,13 @@ function pm_type_as_string(context,tno,distr) result(str) endif end function pm_type_as_string - recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) + recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,tuple_start) type(pm_context),pointer:: context integer,intent(in):: typno character(len=256),intent(inout):: str integer,intent(inout):: n logical,intent(in),optional:: distr,tuple,noequiv + integer,intent(in),optional:: tuple_start type(pm_ptr):: tv,tv2,nv,nv2 integer:: tk,narg,tno2 integer:: name,name2 @@ -2731,7 +2707,13 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) endif endif case(pm_type_is_tuple,pm_type_is_vtuple) - if(add_char('(')) return + istart=1 + if(present(tuple_start)) istart=tuple_start + if(iand(pm_tv_flags(tv),pm_type_is_list)/=0) then + if(add_char('(:')) return + else + if(add_char('(')) return + endif narg=pm_tv_numargs(tv) if(narg==0) then if(add_char(')')) return @@ -2740,7 +2722,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) if(pm_tv_name(tv)/=0) then amps=pm_name_val(context,pm_tv_name(tv)) j=0 - do i=1,narg-1 + do i=istart,narg-1 if(amps%data%i(amps%offset+j)==i) then j=j+1 if(add_char('&')) return @@ -2753,7 +2735,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) endif call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n) else - do i=1,narg-1 + do i=istart,narg-1 call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) if(add_char(',')) return enddo @@ -2762,7 +2744,14 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) if(tk==pm_type_is_vtuple) then if(add_char('...')) return endif - if(add_char(')')) return + if(iand(pm_tv_flags(tv),pm_type_is_when)/=0) then + if(add_char(' when')) return + endif + if(iand(pm_tv_flags(tv),pm_type_is_list)/=0) then + if(add_char(':)')) return + else + if(add_char(')')) return + endif case(pm_type_is_struct,pm_type_is_rec) nv=pm_name_val(context,pm_tv_name(tv)) name=nv%data%i(nv%offset) @@ -2974,10 +2963,25 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv) name=pm_tv_name(tv) if(name/=sym_proc) then if(add_char(trim(pm_name_as_string(context,name)))) return + istart=7 + else + istart=2 endif - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + do i=1,istart + if(pm_type_arg(context,pm_tv_arg(tv,1),i)/=0) then + if(add_char('^')) return + istart=1 + exit + endif + enddo + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,tuple_start=istart) if(add_char('->')) return call pm_type_to_string(context,pm_tv_arg(tv,2),str,n) + if(iand(pm_tv_flags(tv),pm_type_is_yield)/=0) then + if(add_char('yield(')) return + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + if(add_char(')')) return + endif case(pm_type_is_undef_result) name=pm_tv_name(tv) if(add_char('(')) return diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index c9ced15..1a82b18 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -1566,9 +1566,9 @@ subroutine set_op_names op_names(op_this_node)='this_node' op_names(op_this_nnode)='this_nnode' - op_names(op_shared_node)='shared_node' - op_names(op_shared_nnode)='shared_nnode' - op_names(op_is_shared)='is_shared' + op_names(op_shared_node)='shrd_node' + op_names(op_shared_nnode)='shrd_nnode' + op_names(op_is_shared)='is_shrd' op_names(op_is_par)='is_par' op_names(op_push_node_grid)='push_node_grid' op_names(op_push_node_split)='push_node_split' @@ -1612,9 +1612,9 @@ subroutine set_op_names op_names(op_isend_reply)='isend_reply' op_names(op_do_at)='do_at' op_names(op_root_node)='root_node' - op_names(op_bcast_shared_offset)='bcast_shared_offset' - op_names(op_bcast_shared_grid)='bcast_shared_grid' - op_names(op_broadcast_shared)='broadcast_shared' + op_names(op_bcast_shared_offset)='bcast_shrd_offset' + op_names(op_bcast_shared_grid)='bcast_shrd_grid' + op_names(op_broadcast_shared)='broadcast_shrd' op_names(op_isend_grid)='isend_grid' op_names(op_irecv_grid)='irecv_grid' op_names(op_recv_grid)='recv_grid' @@ -2046,8 +2046,8 @@ subroutine set_op_names op_names(op_do_loop)='do_loop' op_names(op_mask)='mask' op_names(op_if)='if' - op_names(op_if_shared)='if_shared' - op_names(op_if_shared_node)='if_shared_node' + op_names(op_if_shared)='if_shrd' + op_names(op_if_shared_node)='if_shrd_node' op_names(op_if_restart)='if_restart' op_names(op_loop)='loop' op_names(op_comm_loop)='comm_loop' @@ -2062,7 +2062,7 @@ subroutine set_op_names op_names(op_blocked_loop)='blocked_loop' op_names(op_over)='over' op_names(op_comm_loop_par)='comm_loop_par' - op_names(op_inline_shared)='inline_shared' + op_names(op_inline_shared)='inline_shrd' op_names(op_assign_farray)='assign_farray' op_names(op_init_farray)='init_farray' op_names(op_wrap)='wrap' diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 2d55131..f779f8e 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -266,7 +266,7 @@ subroutine wcode_procs(wcd) ve=alloc_var(wcd,pm_ve_type) endif wcd%lstack(wcd%ltop)=ve - wcd%loop_extra_arg=iand(cnode_get_num(pr,pr_flags),proc_is_comm) + wcd%loop_extra_arg=iand(cnode_get_num(pr,pr_flags),proccall_is_comm) wcd%proc_can_inline=cnode_flags_clear(proc,& cnode_args+2,proc_is_not_inlinable) wcd%proc_is_chan=cnode_flags_set(pr,pr_flags,proc_run_complete) @@ -957,46 +957,46 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call release_var(wcd,new_ve) endif case(sym_while) - tno=check_arg_type(wcd,args,rv,3) + tno=check_arg_type(wcd,args,rv,2) if(tno==wcd%false_name) return if(restart) return - if(cblock_has_comm(cnode_arg(args,2))& - .or.cblock_has_comm(cnode_arg(args,4))) then + if(cblock_has_comm(cnode_arg(args,1))& + .or.cblock_has_comm(cnode_arg(args,3))) then break=.true. return endif if(pm_is_compiling) then new_ve=alloc_var(wcd,int(pm_logical)) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,ve) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,ve) call wc_call(wcd,callnode,op_assign,111,3,0,ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call wc_call(wcd,callnode,op_loop,0,3,0,ve) pc=comp_start_block(wcd) call wc(wcd,-new_ve) - break2=wcode_cblock(wcd,cnode_arg(args,4),rv,0) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,0) + break2=wcode_cblock(wcd,cnode_arg(args,3),rv,0) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,0) call wc_call(wcd,callnode,op_assign,111,3,0,0) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call comp_finish_block(wcd,pc) else new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_clone_ve,int(new_ve),1,1,ve) jmp=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) pc=wcd%pc - break2=wcode_cblock(wcd,cnode_arg(args,4),rv,new_ve) + break2=wcode_cblock(wcd,cnode_arg(args,3),rv,new_ve) call set_jump_to_here(wcd,jmp) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) call wc_call(wcd,callnode,op_and_jmp_any,& pc,3,1,new_ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call release_var(wcd,new_ve) endif case(sym_until) if(restart) return - if(cblock_has_comm(cnode_arg(args,2))) then + if(cblock_has_comm(cnode_arg(args,1))) then break=.true. return endif @@ -1008,20 +1008,20 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_loop,0,3,0,ve) pc=comp_start_block(wcd) call wc(wcd,-new_ve) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,0) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,0) call wc_call(wcd,callnode,op_not,111,3,1,0) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call comp_finish_block(wcd,pc) else new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_clone_ve,int(new_ve),1,1,ve) pc=wcd%pc - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) call wc_call(wcd,callnode,op_andnot_jmp_any,& pc,3,1,new_ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,new_ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,new_ve) call release_var(wcd,new_ve) endif case(sym_each) @@ -1322,8 +1322,6 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif case(sym_for_stmt) call for_statement - case(sym_each_proc) - call each_proc_body case(sym_any) call any_statement case(sym_pval,sym_pval_as) @@ -1377,6 +1375,10 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,kk),.false.,rv,ve) enddo endif + case(sym_open_smiley) + typ=check_arg_type(wcd,args,rv,1) + call wc_call_args(wcd,callnode,args,op_struct,typ,& + nargs,1,rv,ve) case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref,sym_method_call) i=rvv(cnode_get_num(callnode,call_index)) if(i>pm_type_dref_offset/2) then @@ -1537,7 +1539,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) var_slot(wcd,cnode_arg(args,kk))) enddo endif - case(sym_coherent,sym_partial,sym_set_mode,sym_const,sym_var,& + case(sym_private,sym_set_mode,sym_const,sym_var,sym_null,& sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_assignment) continue ! Nothing to do case(sym_cast) @@ -1688,7 +1690,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) cvar_v2(wcd,slot)/=v_is_array).and.& wcd%loop_extra_arg==0.and..not.wcd%proc_shared_inline.and.& pm_type_get_mode(wcd%context,& - check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))>=sym_mirrored& + check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))>=sym_invar& .or.cvar_kind(wcd,slot2)==v_is_chan_vect) then if(debug_wcode) then write(*,*) 'RETURN actual ASSN',cvar_kind(wcd,slot),& @@ -1737,14 +1739,14 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) else nkeys=cnode_numargs(cnode_get(callnode,call_keys)) endif - if(cnode_flags_clear(callnode,call_flags,call_is_comm)) then + if(cnode_flags_clear(callnode,call_flags,proccall_is_comm)) then call wcode_proc_call(wcd,callnode,rv,ve,-1,& args,nargs,totargs,nkeys,nret,sig) !!$ elseif(pm_is_compiling) then !!$ break=.true. !!$ return else - call wcode_proc_call(wcd,callnode,rv,wcd%lstack(wcd%ltop-1),ve,& + call wcode_proc_call(wcd,callnode,rv,wcd%lstack(max(0,wcd%ltop-1)),ve,& args,nargs,totargs,nkeys,nret,sig) endif end select @@ -1880,100 +1882,6 @@ subroutine any_statement call release_var(wcd,new_ve) end subroutine any_statement - subroutine each_proc_body - integer:: i,j,typ,slot,slot2,slot3 - integer:: n,ii - integer,dimension(:,:),allocatable:: rtns - type(pm_ptr):: u,v,arg - slot=cnode_get_num(callnode,call_index) - slot2=rvv(slot) - if(slot2==0) then - break=wcode_cblock(wcd,cnode_arg(args,nret+2),& - rv,ve) - else - u=pm_dict_val(wcd%context,wcd%sig_cache,int(& - rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) - n=cnode_numargs(u) - v=cnode_arg(args,nret+4) - v=cnode_arg(v,1) - slot=v%data%i(v%offset) - slot2=v%data%i(v%offset+1) - allocate(rtns(nret,0:n-1)) - do i=0,n-1 - if(debug_wcode) write(*,*) 'EACH PROC> Dot',i,'of',n-1 - v=cnode_arg(u,i+1) - rv%data%i(rv%offset+slot:rv%offset+slot2)=& - v%data%i(v%offset:v%offset+slot2-slot) - if(debug_wcode) write(*,*) 'EACH PROC> MOVE OVER',v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - do j=nargs-nret+1,nargs - arg=cnode_arg(args,j) - slot3=cnode_get_num(arg,var_index) - if(debug_wcode) write(*,*) 'EACH PROC> RE-ALLOCATE',slot3 - wcd%rdata(slot3+wcd%base)=alloc_general_var(wcd,arg,rv) - enddo - endif - do j=nret+5,nargs-nret-1,2 - if(pm_is_compiling) then - arg=cnode_arg(args,j+1) - slot3=cnode_get_num(arg,var_index) - if(debug_wcode) write(*,*) 'EACH PROC RE-ALLOCATE(b)',slot3 - wcd%rdata(slot3+wcd%base)=alloc_general_var(wcd,arg,rv) - endif - call wc_arg_get_elem(wcd,callnode,op_elem,cnode_arg(args,j+1),& - cnode_arg(args,j),i+2,rv,ve) - enddo - if(cblock_has_comm(cnode_arg(args,nret+3))) then - call wcode_comm_block(wcd,cnode_arg(args,nret+3),& - wcd%lstack(wcd%ltop-1),rv,ve) - else - break=wcode_cblock(wcd,cnode_arg(args,nret+3),rv,ve) - endif - do j=1,nret - k=cnode_get_num(cnode_arg(args,nargs-nret+j),var_index)+wcd%base - rtns(j,i)=wcd%rdata(k) - enddo - enddo - do j=1,nret - if(pm_is_compiling) then - ii=arg_slot(wcd,cnode_arg(args,j)) - if(cvar_kind(wcd,ii)==v_is_group) then - do i=0,n-1 - call comp_alias_slots(wcd,cvar_ptr(wcd,ii,i+1),rtns(j,i)) - enddo - else - typ=check_arg_type(wcd,args,rv,j) - tv=pm_type_vect(wcd%context,typ) - do i=0,n-1 - if(pm_type_needs_storage(wcd%context,pm_tv_arg(tv,i+1))) then - call comp_assign_slots(wcd,callnode,& - cvar_alloc_elem(wcd,ii,i+1),& - rtns(j,i),& - .true.,rv,ve) - endif - enddo - endif - else - i=check_arg_type(wcd,args,rv,j) - v=pm_type_vect(wcd%context,i) - if(pm_tv_kind(v)==pm_type_is_struct) then - call wc_call(wcd,callnode,op_struct,i,n+2,1,ve) - elseif(pm_tv_kind(v)==pm_type_is_rec) then - call wc_call(wcd,callnode,op_rec,i,n+2,1,ve) - else - call pm_panic('Wcode each proc') - endif - call wc_arg(wcd,cnode_arg(args,j),.true.,rv,ve) - do i=0,n-1 - call wc(wcd,rtns(j,i)) - enddo - endif - enddo - deallocate(rtns) - break=wcode_cblock(wcd,cnode_arg(args,nret+1),rv,ve) - endif - end subroutine each_proc_body - function rvv(n) result(m) integer,intent(in):: n integer:: m @@ -2132,19 +2040,19 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& op2=cnode_get_num(procnode,bi_opcode2) if(cnode_flags_set(procnode,pr_flags,proc_needs_type)) then if(op==op_logical_return) then - if(check_arg_type(wcd,args,rv,1)==wcd%false_name) then + if(check_arg_type(wcd,args,rv,2)==wcd%false_name) then op2=0 else op2=1 endif elseif(op==op_elem) then - if(nargs==3) then - tno=check_arg_type(wcd,args,rv,3) + if(nargs==9) then + tno=check_arg_type(wcd,args,rv,9) p=pm_type_val(wcd%context,tno) op2=p%data%ln(p%offset)+1 endif else - op2=check_arg_type(wcd,args,rv,1) + op2=check_arg_type(wcd,args,rv,2) endif endif if(pm_is_compiling) then @@ -2156,6 +2064,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& ve1=ve2 ignore_args=num_comm_args extra_ve=0 + else + ignore_args=1 endif keep_ctime_const=.true. nproc_keys=0 @@ -2385,11 +2295,6 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) return endif - ! Always inline "each" procs - if(cnode_flags_set(p,pr_flags,proc_is_each_proc)) then - ok=.true. - return - endif ! Forced inline/no-inline in some contexts if(wcd%inline_none) then @@ -2403,11 +2308,11 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) endif ! Check if call and proc definition have no_inline or inline attributes - flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proc_inline+proc_no_inline) - if(iand(flags,proc_no_inline)/=0) then + flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proccall_is_inline+proccall_is_no_inline) + if(iand(flags,proccall_is_no_inline)/=0) then ok=.false. return - elseif(flags==proc_inline) then + elseif(flags==proccall_is_inline) then ok=.true. return endif @@ -2438,10 +2343,10 @@ function preamble(ve) result(ve1) logical:: run_call_complete,run_proc_complete,run_complete,run_if_needed integer:: opcode2 is_par=par_kind<=par_mode_conc - run_shared_or_local=iand(taints,proc_run_shared+proc_run_local)/=0.or.& - .not.cnode_flags_clear(callnode,call_flags,proc_run_shared+proc_run_local) - run_shared=iand(taints,proc_run_shared)/=0.or.& - .not.cnode_flags_clear(callnode,call_flags,proc_run_shared) + run_shared_or_local=iand(taints,proc_run_shared+proc_run_local)/=0 + !.or..not.cnode_flags_clear(callnode,call_flags,proc_run_shared+proc_run_local) + run_shared=iand(taints,proc_run_shared)/=0 + !.or..not.cnode_flags_clear(callnode,call_flags,proc_run_shared) run_call_complete=cnode_flags_set(callnode,call_flags,proc_run_complete) run_proc_complete=iand(taints,proc_run_shared)/=0 run_complete=run_proc_complete.or.run_call_complete @@ -5049,7 +4954,7 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) n=cvar_alloc_slots(wcd,8) v1=5 v2=merge(v_is_shared_dref,v_is_dref,& - pm_type_get_mode(wcd%context,pm_tv_arg(tv,3))>=sym_mirrored) + pm_type_get_mode(wcd%context,pm_tv_arg(tv,3))>=sym_invar) wcd%vinfo(n+3)=dptr(pm_tv_arg(tv,1),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,1),nflags)) wcd%vinfo(n+4)=dptr(pm_tv_arg(tv,2),ior(nflags,iand(flags,v_is_ref))) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,2),ior(nflags,v_is_ref))) @@ -5067,7 +4972,7 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) case(pm_type_is_par_kind) k=pm_tv_name(tv) nflags=flags - if(k>=sym_mirrored) nflags=ior(nflags,v_is_shared) + if(k>=sym_invar) nflags=ior(nflags,v_is_shared) if(k==sym_chan) then nflags=ior(nflags,v_is_chan+v_is_vect) n=cvar_alloc_entry(wcd,v_is_chan_vect,& From b76a0df1aa0380ca360a37bba1860e0a2169ffaf Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 28 Mar 2025 11:51:23 +0000 Subject: [PATCH 11/36] New var and reference implementation --- pm/lib/sys/pm.pmm | 4342 +++------------------------------------ src/array.f90 | 887 +++++--- src/ast.f90 | 11 +- src/cnodes.f90 | 59 +- src/codegen.f90 | 4949 +++++++++++++++++++++------------------------ src/infer.f90 | 885 ++++---- src/opts.f90 | 17 +- src/parlib.f90 | 36 +- src/parser.f90 | 932 +++++---- src/symbol.f90 | 233 ++- src/types.f90 | 950 +++------ src/vm.f90 | 69 +- src/vmdefs.f90 | 23 +- src/wcoder.f90 | 821 ++------ 14 files changed, 4830 insertions(+), 9384 deletions(-) diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm index 9967ddd..9134e50 100644 --- a/pm/lib/sys/pm.pmm +++ b/pm/lib/sys/pm.pmm @@ -2,7 +2,7 @@ PM (Parallel Models) Programming Language Released under the MIT License (MIT) - Copyright (c) Tim Bellerby, 2024 + Copyright (c) Tim Bellerby, 2025 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -24,15 +24,6 @@ */ -/* -type int_literal is ^^^int -type real_literal is ^^^real -type bool_literal is ^^^bool -type string_literal is ^^^string -*/ - -//type literal is ^^^any - PM__intrinsic num_elements(any)->(literal(int)) : "num_elems_fold" PM__intrinsic mod(literal(int),literal(int))->(literal(int)) : "mod_fold" @@ -592,7 +583,6 @@ type real_num is int_num, any_real type cpx_num is real_num,any_cpx type num is cpx_num - // Numeric type conversion proc convert(x,y)=x proc convert(x:int_num,y:sint)=sint(x) @@ -618,8 +608,6 @@ proc as(x:real_num,y:)=real(x) proc as(x:real_num,y:)=scpx(x) proc as(x:real_num,y:)=cpx(x) - - // Auto-conversion on assignment proc PM__assign(&x:num,y:num) { _assign_element(&x,convert(y,x)) @@ -629,7 +617,6 @@ proc PM__assign_var(&x:num,y:num) { PM__assign(&x,convert(y,x)) } - // Mixed arithmatic type _to_sint is int type _to_lint is sint,int @@ -694,6 +681,12 @@ proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) +// Indexed arithmetic +proc +'(x,y)=$+.(x,y) +proc -'(x,y)=$-.(x,y) +proc *'(x,y)=$*.(x,y) +proc /'(x,y)=$/.(x,y) +proc -'(x)=$-.(x) // bool type PM__intrinsic PM__assign_var(&bool,bool): "assign_l" @@ -704,38 +697,6 @@ PM__intrinsic not(bool)->(bool) : "not" PM__intrinsic ==(bool,bool)->(bool) : "eq_l" PM__intrinsic /=(bool,bool)->(bool) : "ne_l" -// Masked types -type masked(x) is rec {_val:x,_there:bool} -proc |(x:masked,y)=if(x._there=>x._val,y) - check "Right operand of ""|"" does not match masked type on the left"=>same_type(x._val,y) - -proc masked(val,there:bool)=new masked { - _val=val,_there=there -} - -proc defined(x:masked)=x._there -proc val(x:masked)=x._val check "masked value is undefined"=>x._there - -proc get(&x,y:masked) { - if y._there{ - x=y._val - } -} - -proc get(&x,y:masked(x)) { - if y._there{ - x=y._val - } - return y._there -} - - - -// Polymorphic types -PM__intrinsic get(x:*any,y:any)->(=y) : "as" -PM__intrinsic<> get(&x:any,y:*any): "get_poly" -PM__intrinsic<> get(&x:any,y:*any)->(bool) : "get_poly2" -PM__intrinsic<> |(x:*any,y:any)->(=y) : "get_poly_or" // val function having null effect proc val(x)=x @@ -746,6 +707,7 @@ proc val(x)=x // ******************************************** // Tuple types + type tuple1d(t1) is rec {PM__d1:t1} type tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2} type tuple3d(t1,t2,t3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3} @@ -763,25 +725,26 @@ type tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t) type tuple(t) is tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),tuple5d(t,t,t,t,t), tuple6d(t,t,t,t,t,t),tuple7d(t,t,t,t,t,t,t) -proc tuple(x)=new tuple1d { + +proc tuple(x)=rec tuple1d { PM__d1=x } -proc tuple(x,y)=new tuple2d { +proc tuple(x,y)=rec tuple2d { PM__d1=x,PM__d2=y } -proc tuple(x,y,z)=new tuple3d { +proc tuple(x,y,z)=rec tuple3d { PM__d1=x,PM__d2=y,PM__d3=z } -proc tuple(x,y,z,t)=new tuple4d { +proc tuple(x,y,z,t)=rec tuple4d { PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t } -proc tuple(x,y,z,t,u)=new tuple5d { +proc tuple(x,y,z,t,u)=rec tuple5d { PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u } -proc tuple(x,y,z,t,u,v)=new tuple6d { +proc tuple(x,y,z,t,u,v)=rec tuple6d { PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v } -proc tuple(x,y,z,t,u,v,w)=new tuple7d { +proc tuple(x,y,z,t,u,v,w)=rec tuple7d { PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w } @@ -1041,6 +1004,7 @@ proc spread(x,y:tuple6d or fix(6))=[x,x,x,x,x,x] proc spread(x,y:tuple7d or fix(7))=[x,x,x,x,x,x,x] proc +(x:tuple(num),y:tuple(num))=map($+,x,y) + proc -(x:tuple(num),y:tuple(num))=map($-,x,y) proc *(x:tuple(num),y:tuple(num))=map($*,x,y) proc /(x:tuple(num),y:tuple(num))=map($/,x,y) @@ -1073,68 +1037,11 @@ proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", // ***************************************************** -// LISTS +// RANGES AND SEQUENCES // ***************************************************** -type _list_node(H,T) is struct{_head:H,_tail:T} -type list(T) is _list_node(T,T or _list_node(T,list(T))) -type _list_end is unique - -proc _cons(a,b)=new _list_node{_head=a,_tail=b} - -proc list(a)<>=_cons(a,_list_end) -proc list(a,...)<>=_cons(a,list(...)) - - -proc reduce(p,a:_list_node)=p.(a._head,reduce(p,a._tail)) -proc reduce(p,a:_list_node(,_list_end))=a._head - -proc map(p,&a:_list_node){p.(a._head);map(p,a._tail)} -proc map(p,&a:_list_node(,_list_end)):p.(a._head) - - -proc map(p,&a:_list_node(,_list_node),b:_list_node(,_list_node)){p.(&a._head,b._head);map(p,&a._tail,b._tail)} - - -proc map(p,&a:_list_node(,_list_end),b:_list_node(,_list_end)):p.(&a._head,b._head) - -proc map(p,&a:_list_node,b:_list_node): test "List lengths do not match"=>fix(false) - -proc map_const(p,&a:_list_node(,_list_node),b){p.(&a._head,b);map_const(p,&a._tail,b)} -proc map_const(p,&a:_list_node(,_list_end),b):p.(&a._head,b) - -proc PM__assign(&a:list,b:list):map($PM__assign,&a,b) -proc PM__assign(&a:list,b):map_const($PM__assign,&a,b) - -proc map(p,a:_list_node)=_cons(p.(a._head),map(p,a._tail)) -proc map(p,a:_list_node(,_list_end))=_cons(p.(a._head),_list_end) - -proc map(p,a:_list_node(,_list_node),b:_list_node(,_list_node))=_cons(p.(a._head,b._head),map(p,a._tail,b._tail)) -proc map(p,a:_list_node(,_list_end),b:_list_node(,_list_end))=_cons(p.(a._head,b._head),_list_end) -proc map(p,a:_list_node,b:_list_node)=_cons(p.(a._head,b._head),_list_end) check "List lengths do not match"=>fix(false) - -proc [](a:list,b:fix(int))=_list_elem(a,b,1) -proc _list_elem(a:_list_node(,_list_node),b:fix(int),c:fix(int)) { - const d - if fix(b==c) { - d=a._head - } else { - d=_list_elem(a,b,c+1) - } - return d -} -proc _list_elem(a:_list_node(,_list_end),b:fix(int),c:fix(int)) { - test "List element out of range"=>a==b - return a._head -} - - /* -// ***************************************************** -// RANGES AND SEQUENCES -// ***************************************************** - // Not in operator proc notin(x,y)=not(x in y) @@ -1150,7 +1057,7 @@ type range_base is real_num // Single point sequence type single_point(t:range_base) is rec {_t:t} -proc single_point(x)=new single_point { +proc single_point(x)=rec single_point { _t=x } proc low(x:single_point)=x._t @@ -1162,10 +1069,10 @@ proc #(x:single_point)=shape([fix(0)..fix(0)]) proc _shp(x:single_point)=fix(0)..fix(0) proc dims(x:single_point)=[fix(1)] proc size(x:single_point)=fix(1) -proc +(x:single_point,y:range_base)=new single_point { +proc +(x:single_point,y:range_base)=rec single_point { _t=x._t+y } -proc -(x:single_point,y:range_base)=new single_point { +proc -(x:single_point,y:range_base)=rec single_point { _t=x._t-y } proc _arb(x:single_point)=x._t @@ -1196,7 +1103,7 @@ proc string(x:single_point)=string("single "++x._t) // Range types type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} -proc ..(x:range_base,y:range_base)=new range { +proc ..(x:range_base,y:range_base)=rec range { _lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) proc low(x:range)=x._lo proc high(x:range)=x._hi @@ -1206,27 +1113,27 @@ proc norm(x:range)=x proc #(x:range(int))=shape([0..x._n-1]) proc dims(x:range(int))=[x._n] proc size(x:range(int))=x._n -proc +(x:range,y:range_base)=new range { +proc +(x:range,y:range_base)=rec range { _lo=x._lo+y,_hi=x._hi+y,_n=x._n } -proc -(x:range,y:range_base)=new range { +proc -(x:range,y:range_base)=rec range { _lo=x._lo-y,_hi=x._hi-y,_n=x._n } proc _arb(x:range)=low(x) proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi -proc convert(x:range,y:range_base)=new range { +proc convert(x:range,y:range_base)=rec range { _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n } -proc sint(x:range)=new range { +proc sint(x:range)=rec range { _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n } -proc int(x:range)=new range { +proc int(x:range)=rec range { _lo=int(x._lo),_hi=int(x._hi),_n=x._n } -proc sreal(x:range)=new range { +proc sreal(x:range)=rec range { _lo=sreal(x._lo),_hi=sreal(x._hi) } -proc real(x:range)=new range { +proc real(x:range)=rec range { _lo=real(x._lo),_hi=real(x._hi),_n=x._n } proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi @@ -1248,13 +1155,13 @@ proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x. proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi -proc empty(x:range)=new range { +proc empty(x:range)=rec range { _lo=x._hi,_hi=x._lo,_n=0 } proc string(x:range)=string(x._lo)++".."++(x._hi) // Cyclic range types (limited functionality and not part of grid) type cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int} -proc cyclic_range(x:int,y:int,w:int)=new cyclic_range { +proc cyclic_range(x:int,y:int,w:int)=rec cyclic_range { _lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) proc low(x:cyclic_range)=x._lo proc high(x:cyclic_range)=x._hi @@ -1266,11 +1173,11 @@ type strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int} type _any_seq(t:range_base):iterable is strided_range(t), ... type _any_seq(t:any_int) is ..., range(t) type seq(t:range_base) is _any_seq(t) -proc _seq(lo,hi,st)=new strided_range { +proc _seq(lo,hi,st)=rec strided_range { _lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y -proc _intseq(x:int,y:int,st:int)= new strided_range { +proc _intseq(x:int,y:int,st:int)= rec strided_range { _lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) proc low(x:strided_range)=x._lo proc high(x:strided_range)=x._hi @@ -1281,26 +1188,26 @@ proc norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n proc align(x:seq)=fix(0) proc #(x:strided_range)=shape([0..x._n-1]) proc dims(x:strided_range)=[x._n] -proc +(x:strided_range,y:range_base)=new strided_range { +proc +(x:strided_range,y:range_base)=rec strided_range { _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n } -proc -(x:strided_range,y:range_base)=new strided_range { +proc -(x:strided_range,y:range_base)=rec strided_range { _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n } proc _arb(x:seq)=x._lo -proc convert(x:strided_range,y:range_base)=new strided_range { +proc convert(x:strided_range,y:range_base)=rec strided_range { _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n } -proc sint(x:strided_range)=new strided_range { +proc sint(x:strided_range)=rec strided_range { _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n } -proc int(x:strided_range)=new strided_range { +proc int(x:strided_range)=rec strided_range { _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n } -proc sreal(x:strided_range)=new strided_range { +proc sreal(x:strided_range)=rec strided_range { _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n } -proc real(x:strided_range)=new strided_range { +proc real(x:strided_range)=rec strided_range { _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n } proc in(x:int,y:strided_range(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 @@ -1325,3995 +1232,252 @@ proc overlap(x:range(any_int),y:strided_range(any_int))=max((-d+y._st-1)/y._st*y proc intersect(x:strided_range(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st proc intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x) PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" -proc intersect(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +proc intersect(x:strided_range(any_int),y:strided_range(any_int))=rec strided_range { _lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) -proc overlap(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +proc overlap(x:strided_range(any_int),y:strided_range(any_int))=rec strided_range { _lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) -proc empty(x:strided_range(any_int))=new strided_range { +proc empty(x:strided_range(any_int))=rec strided_range { _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 } -// Block sequence -type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} -proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ - test "Block sequence width must be non-negative: "++b=>b>=0 - test "Block sequence width must be less than step: "++b++">="++st=>b<=st - test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) -proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st -proc middle_blocks(x:block_seq)=new block_seq { -_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) -proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align -proc low(x:block_seq)=x._lo -proc high(x:block_seq)=x._hi -proc step(x:block_seq)=x._st -proc width(x:block_seq)=x._b -proc norm(x:block_seq)=x -proc align(x:block_seq)=x._align -proc #(x:block_seq)=shape([0..x._n-1]) -proc dims(x:block_seq)=x._n -proc size(x:block_seq)=x._n -proc +(x:block_seq,y:int)=new block_seq { - _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align -} -proc -(x:block_seq,y:int)=new block_seq { - _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align -} -proc _arb(x:block_seq)=x._lo -proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st - if hi-nbhi>=x._b:hi=nbhi+x._b-1 - align=base-(base/x._st)*x._st where base=lo-oldbase - return block_seq(lo,hi,x._st,x._b,align) -} - -proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) -proc overlap(x:range(any_int),y:block_seq) { - z=intersect(y,x) - return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) -} -proc overlap(x:block_seq,y:range(any_int)) { - z=intersect(x,y) - return start..start+size(z)-1 where start=z#z._lo -} -proc overlap(x:block_seq,y:range(any_int)) { - z=intersect(x,y) - return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo -} -proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) -proc empty(x:block_seq)=block_seq(1,0,1,1,0) -// Mapped sequence -type map_seq(t:array(int)) is rec {array:t} -proc map_seq(x:grid_dim){ - var a=array(0,#x) - forall i in a,j in x:i=j - return new map_seq{ - array=a - } -} -proc map_seq(x:array(int,mshape1d))=new map_seq { -array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) -proc _mono(x) { - xs=#x - var ok=true - if x[low(xs.1)]x[i-1]:sync ok=false - } - return ok -} -proc map_seq(x:map_seq)=x -proc #(x:map_seq)=#(x.array) -proc dims(x:map_seq)=size(x.array) -proc size(x:map_seq)=size(x.array) -proc +(x:map_seq,y:range_base)=new map_seq{ - array=x.array+y -} -proc -(x:map_seq,y:range_base)=new map_seq{ - array=x.array-y -} -proc _arb(x:map_seq)=_arb(x.array) -proc element(x:map_seq,y:int)=element(x.array,y) -PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" -PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) -PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) -PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" -PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" -PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) -PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) -PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" -PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" -PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" -proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) -proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) -proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) -proc intersect(x:map_seq,y:map_seq) { - var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) - var n=0 - _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) - v=new map_seq { - array=a[0..n-1] - } - return v -} -proc overlap(x:map_seq,y:map_seq) { - var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) - var n=0 - _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) - v=new map_seq { - array=a[0..n-1] - } - return v -} -proc overlap(x:map_seq,y:map_seq) { - var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) - var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) - var n=0 - _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) - ns=[0..n-1] - v=new map_seq { - array=a[ns] - } - w=new map_seq { - array=b[ns] - } - return v,w -} -proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) -proc expand(t:map_seq,i:range(any_int)) { - var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) - var m=0 - _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) - v=new map_seq { - array=a[0..m-1] - } - return v -} -proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) -proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) -proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) -proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y -proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) -proc #(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) -proc empty(x:map_seq) { - a=array(0,[1..0]) - return new map_seq { - array=a - } -} -// Grids (tuples of sequences) -type _grid_dim(t:range_base) is seq(t),... -type _grid_dim(t:int) is ...,block_seq,map_seq -type grid_dim(t:range_base) is _grid_dim(t) -type grid1d(t1:grid_dim) is [t1] -type grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2] -type grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is [t1,t2,t3] -type grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is [t1,t2,t3,t4] -type grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim) is [t1,t2,t3,t4,t5] -type grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim) is [t1,t2,t3,t4,t5,t6] -type grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim,t7:grid_dim) is [t1,t2,t3,t4,t5,t6,t7] -type grid(t:range_base) is tuple(grid_dim(t)) -proc #(x:grid)=shape(map($_shp,x)) -proc dims(x:grid)=map($_size,x) -proc +(x:grid,y:tuple(range_base))=map($+,x,y) -proc -(x:grid,y:tuple(range_base))=map($+,x,y) -proc empty(x:grid)=map($empty,x) -proc element(x:grid_dim,y:grid_dim){ - var a=array(0,#y) - forall i in a,j in y:i=x[j] - return new map_seq{ - array=a - } -} -proc element(x:grid,y:grid)=map($element,x,y) -// Slices of grids (may have dims that are just an integer and also _ or _() or null) -type grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null -type grid_slice(t) is grid(t),tuple(grid_slice_dim(t)) -// Some limited functionality for extended grids (which include cyclic ranges) -type iterable_dim is grid_slice_dim,cyclic_range,... -type iterable_grid is tuple(iterable_dim),grid_slice -proc _shp(x:iterable_dim)=0..size(x)-1 -proc size(x:iterable_dim)->(int)... -proc element(x:iterable_dim,y)=error_type()check "Cannot index this type with a non-integer index"=>fix(false) -proc element(x:iterable_dim,y:int)->(any)... -proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) -proc _shp(x:stretch_dim)=null -proc _shp(x:null)=x -proc _size(x:stretch_dim or null)=fix(1) -proc _size(x)=size(x) -PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" -proc _act(x)=x -proc _sliceit(...)=tuple(...) -proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) -proc active_dims(x:single_point)=null -PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" -proc _act(x,y)=y -proc active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y) -proc active_dims(x:single_point,y)=null -proc _ar(x:single_point)=0 -proc _ar(x)=1 -proc rank(x:iterable_grid)=map_reduce($_ar,$+,x) -proc element(x:iterable_grid,y:index){ - t=_tup(y) - return _ges(head(x),tail(x),head(t),tail(t),fix(false)) -} -proc element(x:grid_slice,...:grid_slice){ - t=_tup(...) - return _ges(head(x),tail(x),head(t),tail(t),fix(true)) -} - -proc element(x:null,y)=null -proc _spnt(i,y:fix(true))=i -proc _spnt(i,y:fix(false))=i._t -proc _spif(i:int,y:fix(true))=single_point(i) -proc _spif(i,y:fix(true))=i -proc _spif(i,y:fix(false))=i -proc _ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) -proc _ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => fix(false) -proc _ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),_ges(head(x),tail(x),head(y),tail(y),t)) -proc _ges_null(i,x,j,y,t:fix(true))=prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t)) -proc _ges_null(i,x,j,y,t:fix(false))=_ges(head(x),tail(x),head(y),tail(y),t) -proc _ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t) -proc _ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) -proc _ges(i:empty_head,x,j:empty_head,y,t)=null -proc _ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => fix(false) -proc _ges(i:null,x,j:empty_head,y,t:fix(true))=error_type() :test "Rank mismatch" => fix(false) -proc _ges(i:null,x,j:empty_head,y,t:fix(false))=null -proc size(x:iterable_grid)=map_reduce($_size,$*,x) -proc #(x:grid_slice)=shape(map($_shp,active_dims(x))) -proc dims(x:iterable_grid)=map($_size,active_dims(x)) -proc _arb(x:grid_slice)=map($_arb,x) -proc in(x:tuple(range_base),y:grid_slice)=map_reduce($in,$and,x,y) -proc inc(x:grid_slice,y:grid_slice)=map_reduce($inc,$and,x,y) -proc #(x:grid,y:tuple(subs_dim))=map($#,x,y) -PM__intrinsic _acthash(x:single_point,y:any)->(PM__tinyint) : "miss_arg" -proc _acthash(x,y)=x#y -proc #(x:grid_slice,y:tuple(subs_dim) or grid_slice)=map_apply($_acthash,$_sliceit,x,y) -proc convert(x:grid_slice,y:real_num)=map_const($convert,x,y) -proc sint(x:grid_slice)=map($sint,x) -proc int(x:grid_slice)=map($int,x) -proc sreal(x:grid_slice)=map($sreal,x) -proc real(x:grid_slice)=map($real,x) -proc low(x:grid_slice)=map($low,x) -proc high(x:grid_slice)=map($high,x) -proc overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y) -proc overlap(x:grid_slice,y:grid_slice)=u,v where u,v=map($overlap,x,y) -proc intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y) -proc intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y)) -proc overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y)) -proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y)) -proc expand(x:grid_slice,y:grid)=map($expand,x,y) -proc contact(x:grid_slice,y:grid)=map($contract,x,y) -PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" -// ***************************************************** -// SHAPES -// ***************************************************** -type extent is tuple(range(int) ),extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d -type extent1d is tuple1d_of(range(int)) -type extent2d is tuple2d_of(range(int)) -type extent3d is tuple3d_of(range(int)) -type extent4d is tuple4d_of(range(int)) -type extent5d is tuple5d_of(range(int)) -type extent6d is tuple6d_of(range(int)) -type extent7d is tuple7d_of(range(int)) -type mshape(extent_t:extent) is rec {use _extent:extent_t,_n:int,_o:int} -type mshape1d is mshape(extent1d) -type mshape2d is mshape(extent2d) -type mshape3d is mshape(extent3d) -type mshape4d is mshape(extent4d) -type mshape5d is mshape(extent5d) -type mshape6d is mshape(extent6d) -type mshape7d is mshape(extent7d) +*/ -// Create array, vector and matrix shapes -proc _low(x)=low(x) -proc _low(x:null)=fix(0) -proc _off(x)=-index(dims(x),map($_low,x)) -proc PM__array(...)=shape(map($_extnt,[...])) -proc _extnt(n:any_int)=0..int(n)-1 -proc _extnt(n:null)=null -proc _extnt(n:range(any_int))=int(n) -proc shape(extent:extent)=new mshape { - _extent=extent,_n=size(extent),_o=_off(extent) +// *************************************************** +// LOOPS AND PARALLEL STATEMENTS +// *************************************************** + +proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) <> { + PM__for shape { + here_in_tile=PM__generate(shape,shape) + old_dump(here_in_tile) + PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { + var inouts=PM__import(PM__inouts) + var inout_a=PM__get_elem(PM__inout_a,here_in_tile) + PM__block_proc.'(&inouts, + PM__import(PM__ins), + &inout_a, + PM__get_elem(PM__in_a,here_in_tile), + PM__get_elem(PM__star_a,here_in_tile) <>) + PM__export(&PM__inouts,inouts) + PM__set_elem(&PM__inout_a,inout_a,here_in_tile) + } + } } -// Conforming mshapes -proc check_conform(x,y) { - check_conform(#x,#y) -} -proc check_conform(x:mshape,y:mshape) { - test "Mshapes "++x++" and "++y++" do not conform"=>conform(x,y) -} - -proc _conform(x,y)=size(x)==size(y) -proc _conform(x:null,y)=size(y)==fix(1) -proc _conform(x,y:null)=fix(true) -proc _conform(x:null,y:null)=fix(true) -proc conform(x:mshape,y:mshape)=map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0check "Values of different ranks cannot conform"=>rank(x)==rank(y) +proc PM__chan_stmt'() yield() { yield() } +proc PM__over_stmt'(x) yield() { yield() } -// Local size of a mshape -proc _local_size(x:mshape)=size(x._extent) +proc #(x)=x -// Convert an extent to have a zero base -proc zero_base(x:range)=0..size(x)-1 -proc zero_base(x:extent)=map($zero_base,x) +proc PM__check_iter(x){} +proc PM__check_iter_amp(x){} +proc PM__check_iter_star(x){} +proc PM__check_iter(x,y){} +proc PM__check_iter_amp(x,y){} +proc PM__check_iter_star(x,y){} -// Extent of a mshape -proc extent(x:shape)=x._extent +proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):h) +proc PM__get_elem(x,h)=h +proc PM__set_elem(&x,y,h) {} +proc PM__export(&x,y) {} -// Dimensions of a mshape -proc dims(x:mshape)=map($size,x._extent) +proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(element_at_index(x,i))) +PM__intrinsic PM__import(x:any)->(=x) : "import_val" -// Size from dimensions -proc size(x:tuple(int))=reduce($*,x) +proc PM__generate(x,n)=old_dumpit(_elts(x,1,n)) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=old_dumpit(_iota(siz,0,x,1,tot)) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) -// Empty mshape -proc _empty(x)=1..0 -proc empty(x:extent)=map($_empty,x) +// ************************************************** +// SUPPORT FOR OTHER LANGUAGE FEATURES +// ************************************************** -// Slice of mshape -proc [](x:mshape,s:index)=x._extent[s] -proc [](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,fix(true)))):check_contains(x,s) +// Keyword arguments +proc PM__getkey(x:any,y:any)=convert(x,y) +proc PM__getkey(x:null,y:any)=y +// Switch statement +proc PM__checkcase(x:literal,y:literal)=match_switch_case(x,y) +proc PM__checkcase(x,y)=match_switch_case(x,y) +proc match_switch_case(x:literal,y:literal)=x==y +proc match_switch_case(x:fix(any),y:fix(any))=x==y +proc match_switch_case(x,y)=x==y +proc match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi +proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:literal(int),y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x +type _crange is rec{_lo,_hi} +proc PM__caserange(x,y)=x..y +proc PM__caserange(x:fix(int),y:fix(int))=rec _crange{ + _lo=x,_hi=y +} -// ***************************************************** -// INDEXING AND SLICING -// ***************************************************** +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:fix(true),y,z)=y +proc PM__if(x:fix(false),y,z)=z +proc PM__if(x:fix(true),y:literal,z)=y +proc PM__if(x:fix(false),y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) -// Generic types supporting indexing and mapping -type iterable is iterable_grid,grid_slice,grid,grid_slice_dim,cyclic_range,array,... -proc [](x:iterable,...){ - d=#x - y=_tup(...) - check_contains(d,y) - return element(x,fill_in(d,y,fix(false))) +// Assignment +proc PM__assign_or_init(a,b)<>=a { + PM__assign_var(&^(a),b) } -// Index type -type index is any_int,tuple(any_int) +proc PM__assign_or_init(a:,b)=PM__dup(b as a) -// Slice and subscript types -type range_below(x) is rec {_t:x} -type range_above(x) is rec {_t:x} -type strided_range_below(x) is rec {_t:x,_st:x} -type strided_range_above(x) is rec {_t:x,_st:x} -type stride(x) is rec {_st:x} -type slice_dim is range(any_int),strided_range(any_int),range_above(any_int), range_below(any_int),strided_range_above(any_int),strided_range_below(any_int), stride(any_int),null,stretch_dim -type slice is slice_dim,tuple(slice_dim) -type subs_dim is slice_dim,any_int -type subs is index,slice,subs_dim,tuple(subs_dim) +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} -// Partial ranges/sequences mainly used in subscripts -proc ..._(x)=new range_below { - _t=x +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a } -proc _...(x)=new range_above { - _t=x + +/* +type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... + +proc PM__assign(&a:any,b:any,c:assignment_operator) { + PM__assign(&a,c.(a,b)) } -proc by(x:range_base)=new stride { - _st=x +*/ + +proc PM__assign(&a:any,b:any,c:proc) { + test "Not a recognised assignment operator"=>fix(false) } -proc by(x:range_above(),y)=new strided_range_above { - _t=x._t,_st=convert(y,x._t) + +proc check_assign_types(x,y){ + test "Type mismatch in assignment"=>same_type(x,y) } -proc by(x:range_below(),y)=new strided_range_below { - _t=x._t,_st=convert(y,x._t) +proc _assign(&a,b) { + _assign_element(&a,b) } -proc string(x:range_above)=x._t++"..." -proc string(x:range_below)="..."++x._t -proc string(x:strided_range_above)=x._t++"... by"++x._st -proc string(x:strided_range_below)="..."++x._t++"by "++x._st -proc string(x:stride)="by "++x._st -proc low(x:range_above)=x._t -proc low(x:strided_range_above)=x._t -proc high(x:range_below)=x._t -proc high(x:strided_range_below)=x._t -proc step(x:range_above or range_below)=fix(1) -proc step(x:strided_range_above or strided_range_below)=x._st -proc width(x:strided_range_above or strided_range_below or range_above or range_below)=fix(1) -// Stretch dimension in subscript -type stretch_dim is unique{PM__strdim} -proc string(x:stretch_dim)="_" -proc size(x:stretch_dim)=fix(1) -proc expand(x:stretch_dim,y:grid)=x -proc contract(x:stretch_dim,y:grid)=x -proc in(x:stretch_dim,y)=fix(true) -proc inc(x:stretch_dim,y)=fix(true) -proc convert(x:stretch_dim,y:range_base)=x -proc #(x:stretch_dim,y:index)=fix(0) -proc #(x:stretch_dim,y:grid_slice_dim)=fix(0)..fix(0) -proc intersect(x:stretch_dim,y:grid_slice_dim)=y -proc intersect(x:grid_slice_dim,y:stretch_dim)=x -proc intersect(x:stretch_dim,y:stretch_dim)=x -proc overlap(x:grid_slice_dim,y:stretch_dim)=#x -proc overlap(x:stretch_dim,y:grid_slice_dim)=fix(0)..fix(0) -proc overlap(x:stretch_dim,y:stretch_dim)=fix(0)..fix(0) - -// Check subscript is in range -proc check_contains(a:extent,...) { - test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(...) -} -proc check_contains(a:mshape,...) { - check_contains(a._extent,...) +/* +proc _assign(&a:contains(farray),b) { + _assign_structure(&a,b) } -proc check_contains(a,...) { - check_contains(#a,...) +*/ +/* +proc _assign_structure(&a,b)<>{ + _assign_element(&a,b) } -proc check_contains(a:dshape,...) { - check_contains(a._mshape._extent,...) +proc _assign_structure(&a:farray,b){ + _array_assign(&a,b,fix(true)) } -proc _contains(x:null,y)=fix(true) -proc _contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y) -proc _contains(x:range(int),y:range(any_int) or seq(any_int))=_contains(x,y._lo) and _contains(x,y._hi) or y._lo>y._hi -proc _contains(x:range(int),y:range_below(any_int) or strided_range_below(any_int) or range_above(any_int) or strided_range_above(any_int))=_contains(x,y._t) -proc _contains(x:range(int),y:stride(any_int))=fix(true) -proc _contains(x:range(int),y:null)=fix(true) -proc contains(x:mshape1d,y:subs_dim)=_contains(x.1,y) -proc contains(x:extent,y:tuple(subs_dim))=map_reduce($_contains,$and,x,y) -PM__intrinsic _rgd(x:stretch_dim)->(PM__tinyint) : "miss_arg" -proc _rgd(x)=x -proc _rigid_dims(x:grid_slice or tuple(subs_dim))=map_apply($_rgd,$_sliceit,x) -proc contains(x:extent,y:tuple(subs_dim) and contains(stretch_dim))=contains(x,_rigid_dims(y)) -proc contains(x:extent,y,...)=contains(x,[y,...]) +*/ +PM__intrinsic _assign_element(&any,any): "assign" + + +// Other variable operations -// Complete a subscript using a base mshape -proc fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => fix(false) -proc fill_in(x:seq(int) or null,y:any_int,t:fix(true))=single_point(int(y)) -proc fill_in(x:seq(int) or null,y:any_int,t:fix(false))=int(y) -proc fill_in(x:seq(int) or null,y:any_int,t:null)=int(y)..int(y) -proc fill_in(x:seq(int) or null,y:range(any_int),t)=int(y) -proc fill_in(x:seq(int) or null,y:strided_range(any_int),t)=int(y) -proc fill_in(x:seq(int),y:range_below(any_int),t)=x._lo..int(y._t) -proc fill_in(x:seq(int),y:range_above(any_int),t)=int(y._t)..x._hi -proc fill_in(x:seq(int),y:strided_range_below(any_int),t)=lo..int(y._t) by y._st where lo=y._t-(y._t-x._lo)/y._st*y._st -proc fill_in(x:seq(int),y:strided_range_above(any_int),t)=int(y._t)..x._hi by y._st -proc fill_in(x:seq(int),y:stride(any_int),t)=x by int(y._st) -proc fill_in(x:seq(int) or null,y:null,t)=x -proc fill_in(x:grid,y:tuple(any_int),t)=int(y) -proc fill_in(x:grid,y:tuple(subs_dim),t)=map($fill_in,x,y,spread(t,x)) -proc fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim),t)=_fill_in(x,head(y),tail(y),t) -proc _fill_in(x,y,z,t)=prepend(fill_in(x.1,y,t),_fill_in(tail(x),head(z),tail(z),t)) -proc _fill_in(x,y:stretch_dim,z,t:fix(true))=prepend(null,_fill_in(x,head(z),tail(z),t)) -proc _fill_in(x,y:stretch_dim,z,t:fix(false))=prepend(y,_fill_in(x,head(z),tail(z),t)) -proc _fill_in(x:null,y:empty_head,z,t)=null -proc _fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t)) -proc _fill_in(x:empty_head,y,z,t)=error_type() :test "Rank mismatch in slice" => fix(false) +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv +PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv +PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" -// ******************************************************* -// SUBSCRIPT INTERSECTION AND ALIASING -// ******************************************************* -// Test for intersection between two subscripts -proc intersects(x:null,y:subs_dim)=fix(true) -proc intersects(x:subs_dim,y:null)=fix(true) -proc intersects(x:null,y:null)=fix(true) -proc intersects(x:range(any_int),y:range(any_int))=not(x._hiy._hi) -proc intersects(x:seq(any_int),y:seq(any_int))=size(intersect(x,y))>0 -proc intersects(x:range(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._hi>=y._t -proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range(any_int))=y._hi>=x._t -proc intersects(x:range(any_int),y:range_below(any_int) or strided_range_below(any_int))=x._lo<=y._t -proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range(any_int))=y._lo<=x._t -proc intersects(x:strided_range(any_int),y:range_above(any_int) or strided_range_above(any_int))=intersects(y._t..x._hi by step(y),x) -proc intersects(y:range_above(any_int) or strided_range_above(any_int),x:strided_range(any_int))=intersects(y._t..x._hi by step(y),x) -proc intersects(x:strided_range(any_int),y:range_below(any_int) or strided_range_below(any_int))=intersects(x,y._t..x._lo by -step(y)) -proc intersects(y:range_below(any_int) or strided_range_below(any_int),x:strided_range(any_int))=intersects(x,y._t..x._lo by -step(y)) -proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._t>=y._t -proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_below(any_int) or strided_range_below(any_int))=y._t>=x._t -proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_above(any_int) or strided_range_above(any_int))=fix(true) -proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_below(any_int) or strided_range_below(any_int))=fix(true) -proc intersects(x:strided_range_below(any_int),y:strided_range_above(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 -proc intersects(y:strided_range_above(any_int),x:strided_range_below(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 -proc intersects(x:strided_range_above(any_int),y:strided_range_above(any_int))=abs(x._t-y._t) mod gcd(int(x._st),int(y._st))==0 -proc intersects(x:strided_range_below(any_int),y:strided_range_below(any_int))=abs(x._t-y._t) mod gcd(abs(int(x._st)),abs(int(y._st)))==0 -proc intersects(x:stride(any_int),y:subs_dim)=fix(true) -proc intersects(x:subs_dim,y:stride(any_int))=fix(true) -proc intersects(x:stride(any_int),y:stride(any_int))=fix(true) -proc intersects(x:seq,y:int)=y in x -proc intersects(x:int,y:seq)=x in y -proc intersects(x:int,y:int)=x==y -proc intersects(x:int,y:range_above(any_int))=x>=y._t -proc intersects(x:int,y:range_below(any_int))=x<=y._t -proc intersects(x:int,y:strided_range_above(any_int))=x>=y._t and (x-y._t) mod y._st==0 -proc intersects(x:int,y:strided_range_below(any_int))=x<=y._t and (y._t-x) mod y._st==0 -proc intersects(y:range_above(any_int),x:int)=x>=y._t -proc intersects(y:range_below(any_int),x:int)=x<=y._t -proc intersects(y:strided_range_above(any_int),x:int)=x>=y._t and (x-y._t) mod y._st==0 -proc intersects(y:strided_range_below(any_int),x:int)=x<=y._t and (y._t-x) mod y._st==0 -proc _intersects(x,y,z:fix(true))=map_reduce($intersects,$and,x,y) -proc _intersects(x,y,z:fix(false))=fix(false) -proc intersects(x:tuple(subs_dim except stretch_dim),y:tuple(subs_dim except stretch_dim))=_intersects(x,y,rank(x)==rank(y)) -proc intersects(x:tuple(subs_dim),y:tuple(subs_dim))=_intersects(rx,ry,rank(rx)==rank(ry))where rx=_rigid_dims(x),ry=_rigid_dims(y) -proc intersects(x:tuple(subs_dim),y:null)=fix(true) -proc intersects(x:null,y:tuple(subs_dim))=fix(true) -proc _intersects(x:subs,y:subs)=intersects(x,y) -proc _intersects(x,y)=fix(false) +PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" +/* +PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" +PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" +PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" +PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" +PM__intrinsic PM__dup(x:literal(int))->(int) : "clone" +PM__intrinsic PM__dup(x:literal(real))->(real) : "clone" +PM__intrinsic PM__dup(x:literal(string))->(string) : "clone" +PM__intrinsic PM__dup(x:literal(bool))->(bool) : "clone" +*/ +PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" +PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" -// Alias checking -proc PM__check_alias(...)=false -proc PM__check_alias(i,j,x,y) { - test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) +/* +proc ==(x:any,y:any) { + test "Cannot apply ""=="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return not ok } -proc PM__check_alias(i,j,x,y,...) { - if _intersects(x,y):PM__check_alias(i,j,...) +proc _eq(x:any,y:any,&ok) <> { + ok=ok and x==y } +*/ -// Combining subscripts -proc PM__cmbidx(x,y)=_cmb(x,y) -proc PM__cmbidx(x,y,...)=PM__cmbidx(_cmb(x,y),...) -type _cmb_error is unique -proc _cmb(x,y)=_cmb_error -proc _cmb(x:subs except index,y:subs)=_cmb1(x,y) -proc _cmb1(x,y)=_cmb_error -proc _cmb1(x:subs_dim,y:subs_dim)=x[y] -proc _cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y)) -proc _cmb2(x,y,z:fix(true))=x[y] -proc _cmb2(x,y,z:fix(false))=_cmb_error +proc PM__valref(x)=x +proc PM__check_alias(...){} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) -// ******************************************************* -// ITERATION - SEQUENTIAL AND CONCURRENT -// ******************************************************* -// Iteration over mshape -// - first element -proc PM__first(d:int)=0,null,d>0 -proc PM__first(d:tuple1d)=i,s,e where i,s,e=PM__first(d.1) -proc PM__first(d:tuple2d)=[j1,j2],[s1,s2],e1 and e2 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2) -proc PM__first(d:tuple3d)=[j1,j2,j3],[s1,s2,s3],e1 and e2 and e3 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3) -proc PM__first(d:tuple4d)=[j1,j2,j3,j4],[s1,s2,s3,s4],e1 and e2 and e3 and e4 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4) -proc PM__first(d:tuple5d)=[j1,j2,j3,j4,j5], [s1,s2,s3,s4,s5],e1 and e2 and e3 and e4 and e5 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5) -proc PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],[s1,s2,s3,s4,s5,s6],e1 and e2 and e3 and e4 and e5 and e6 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6) -proc PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],[s1,s2,s3,s4,s5,s6,s7],e1 and e2 and e3 and e4 and e5 and e6 and e7 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7) +PM__intrinsic<> .element_at_index(&x:any,y:fix(int))->(|x):"elem" +PM__intrinsic<> element_at_index(x:any,y:fix(int))->(|x):"elem" -// - subsequent elements -proc PM__next(d:int,g,i)=ii,null,ii> _doloop(int)->(int) : "do_loop" -PM__intrinsic<> _doloop(int,int)->(int,int) : "do_loop" -PM__intrinsic<> _doloop(int,int,int)->(int,int,int) : "do_loop" -PM__intrinsic<> _doloop(int,int,int,int)->(int,int,int,int) : "do_loop" -PM__intrinsic<> _doloop(int,int,int,int,int)->(int,int,int,int,int) : "do_loop" -PM__intrinsic<> _doloop(int,int,int,int,int,int)->(int,int,int,int,int,int) : "do_loop" -PM__intrinsic<> _doloop(int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "do_loop" -proc _elts(x:int)=i where i=_doloop(x) -proc _elts(x:tuple1d)=[i] where i=_elts(x.1) -proc _elts(x:tuple2d)=[i,j] where i,j=_doloop(x.1,x.2) -proc _elts(x:tuple3d)=[i,j,k] where i,j,k=_doloop(x.2,x.2,x.3) -proc _elts(x:tuple4d)=[i,j,k,l] where i,j,k,l=_doloop(x.1,x.2,x.3,x.4) -proc _elts(x:tuple5d)=[i,j,k,l,m] where i,j,k,l,m=_doloop(x.1,x.2,x.3,x.4,x.5) -proc _elts(x:tuple6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_doloop(x.1,x.2,x.3,x.4,x.5,x.6) -proc _elts(x:tuple7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7) -PM__intrinsic<> _blockedloop(any)->(int) : "blocked_loop" -PM__intrinsic<> _blockedloop(any)->(int,int) : "blocked_loop" -PM__intrinsic<> _blockedloop(any)->(int,int,int) : "blocked_loop" -PM__intrinsic<> _blockedloop(any)->(int,int,int,int) : "blocked_loop" -PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int) : "blocked_loop" -PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int) : "blocked_loop" -PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int,int) : "blocked_loop" -proc _belts(x,y:shape1d)=[i] where i=_blockedloop(PM__do_over(x,y)) -proc _belts(x,y:shape2d)=[i,j] where i,j=_blockedloop(PM__do_over(x,y)) -proc _belts(x,y:shape3d)=[i,j,k] where i,j,k=_blockedloop(PM__do_over(x,y)) -proc _belts(x,y:shape4d)=[i,j,k,l] where i,j,k,l=_blockedloop(PM__do_over(x,y)) -proc _belts(x,y:shape5d)=[i,j,k,l,m] where i,j,k,l,m=_blockedloop(PM__do_over(x,y)) -proc _belts(x,y:shape6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_blockedloop(PM__do_over(x,y)) -proc _belts(x,y:shape7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y)) -PM__else -proc PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n) -proc PM__generate(x:mshape,n,s)=_elts(dims(x),1,n) -PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" -PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" -proc _n(x:int)=x -proc _elts(x:int,siz,tot)=_iota(siz,0,x-1,1,tot) -proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) -proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) -proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) -proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) -proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) -proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) -proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) -PM__endif -PM__intrinsic _indices(any)->(int) : "indices" -// ************************************** -// ARRAYS -// ************************************** -// Array types -type array(e,d:shape) is varray(e,d),farray(e,d) -type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) -type farray(e,d:shape) is e^const d,e^invar d,e^fix(d),array_template(e,d,fix(false)) -type farray(e,d:mshape) is ...,array_slice(e^const any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix(any)) -// Array operations -proc _arb(x:any^mshape)=_get_aelem(x,0) -PM__if_compiling -proc size(x:any^mshape)=size(#x) -PM__else -PM__intrinsic size(x:any^mshape)->(int) : "get_size" -PM__endif -PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(false))->(PM__dim x,y) : "array" -PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(true))->(PM__vdim x,y) : "var_array" -PM__intrinsic<> _redim(x:any^any,y:any)->(over x,y) : "redim" -PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(PM__dim x,y) : "array_noinit" -proc #%(x:invar any^any)=_array_shape(x <>) -proc #%(x)=_get_shape(x) -proc _get_shape(x)=#x -proc #(x:any^any)=_array_shape(x) -PM__intrinsic _array_shape(x:any^any)->(#x) : "get_dom" -proc dims(x:any^mshape)=dims(#x) -PM__intrinsic PM__extractelm(x:any^any)->(%x) : "extractelm" -proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) -proc _set_elem(&a:any^mshape,v,t:index){ - PM__setaelem(&a,index(#(a),t),v) -} - -proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) -PM__intrinsic _make_subref(a:any^mshape,i:int)->(%a) : "make_rf" -PM__intrinsic _get_aelem(x:any^any,y:int)->(%x) : "array_get_elem" -PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" -// Linear index of tuple mshape (zero base,unit stride) -proc _indx(g:null,s)=fix(0) -proc _indx(g:range(int),s)=int(s) -proc _indx(g:any_int,s)=int(s) -proc _sz(x:null)=fix(1) -proc _sz(x:int)=x -proc _sz(x:range(int))=x._n -proc _offset(x:mshape)=x._o -proc _offset(x)=fix(0) -proc index(g:mshape1d or tuple1d_of(int),s:any_int)=int(_indx(g.1,s))+_offset(g) -proc index(g:mshape1d or tuple1d_of(int),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g) -proc index(g:mshape2d or tuple2d_of(int),s:tuple2d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2))+_offset(g) -proc index(g:mshape3d or tuple3d_of(int),s:tuple3d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3)))+_offset(g) -proc index(g:mshape4d or tuple4d_of(int),s:tuple4d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4))))+_offset(g) -proc index(g:mshape5d or tuple5d_of(int),s:tuple5d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5)))))+_offset(g) -proc index(g:mshape6d or tuple6d_of(int),s:tuple6d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6))))))+_offset(g) -proc index(g:mshape7d or tuple7d_of(int),s:tuple7d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7))))))))+_offset(g) -proc index2point(i:int,s:range(int))=[i+s._lo] -proc index2point(i:int,s:int)=[i] -proc index2point(i:int,s:tuple1d_of(int))=[i] -proc index2point(i:int,s:tuple2d_of(int))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) -proc index2point(i:int,s:tuple3d_of(int))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) -proc index2point(i:int,s:tuple4d_of(int))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) -proc index2point(i:int,s:tuple5d_of(int))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) -proc index2point(i:int,s:tuple6d_of(int))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) -proc index2point(i:int,s:tuple7d_of(int))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) -// Numeric array operations -proc -(x:num^any)={ - -xx:xx in x -} -proc +(x:num^any,y:num)={ - xx+y:xx in x -} -proc -(x:num^any,y:num)={ - xx-y:xx in x -} -proc *(x:num^any,y:num)={ - xx*y:xx in x -} -proc *(x:num,y:num^any)={ - x*yy:yy in y -} -proc /(x:num^any,y:num)={ - xx/y:xx in x -} -// ***************************************** -// ARRAY TEMPLATES -// ***************************************** -// Array templates -type array_template(a,d:mshape or dshape,v:fix(bool)) is rec {_a:a,_d:d,_s:int,_v:v} -proc array(a:any,s:dshape)=new array_template { - _a=a,_d=s,_s=s._size,_v=fix(false) -} -proc array(a:any,s:mshape(tuple(range(int))))=new array_template { - _a=a,_d=s,_s=size(s),_v=fix(false) -} -proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) -proc varray(a:any,s:mshape or dshape)=new array_template { - _a=a,_d=s,_s=size(s),_v=fix(true) -} -proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) -proc _zero(x)=0 -proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) -// Treat a template as if it were an array -proc _arb(a:array_template)=a._a -proc #(a:array_template(,mshape,))=a._d -proc dims(a:array_template(,mshape,))=dims(a._d) -proc size(a:array_template)=a._s -proc redim(a:array_template,d:mshape)= new array_template { -_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s -proc element(a:array_template,...:subs)=a._a -// Array creation from template -proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) -proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) -proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) -// ***************************************** -// MATRIX AND VECTOR -// ***************************************** -type matrix_element is num,bool,... -type _matrix(t) is struct{use array:t} -type matrix(t:matrix_element) is _matrix(array(t,shape2d)) -type vector(t:matrix_element) is _matrix(array(t,shape1d)) -type matrix_template(t:matrix_element) is _matrix(array_template(t,shape2d)) -type vector_template(t:matrix_element) is _matrix(array_template(t,shape1d)) -proc PM__matrix(x)=new _matrix{ - array=x -} -proc vector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n)) -proc vvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n)) -proc dvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) -proc dvvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) -proc vector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(array(x,n,distr)) -proc vvector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(varray(x,n)) -proc matrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n)) -proc vmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n)) -proc dmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) -proc dvmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) -proc matrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(array(x,n,distr)) -proc vmatrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(varray(x,n)) -proc matrix_element_zero(x:num)=convert(0,x) -proc matrix_element_balance(x:num,y:num)=xx,yy where xx,yy=balance(x,y) -proc matrix_element_add(x:num,y:num)=x+y -proc matrix_element_subtract(x:num,y:num)=x-y -proc matrix_element_multiply(x:num,y:num)=x*y -proc matrix_element_zero(x:bool)=false -proc matrix_element_balance(x:bool,y:bool)=x,y -proc matrix_element_add(x:bool,y:bool)=x or y -proc matrix_element_multiply(x:bool,y:bool)=x and y -proc +(x:matrix,y:matrix) { - check_conform(x.array,y.array) - test "Cannot add zero size matrices"=>size(x)>0 - var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) - for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_add(xx,yy) return z -} -proc -(x:matrix,y:matrix) { - check_conform(x.array,y.array) - test "Cannot add zero size matrices"=>size(x)>0 - var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) - for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_subtract(xx,yy) return z -} -proc *(x:matrix,y:matrix) { - sx=#x - sy=#y - sz=[sx.1,sy.2] - test "Matrices do not conform for multiplication"=>size(sx.2)==size(sy.1) - test "Cannot multiply zero size matrices"=>size(x)>0 and size(y)>0 - var z=matrix(b,sz) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) - for *i in sz,zz in z.array { - var s=matrix_element_zero(_arb(z.array)) - foreach invar k in #(sx.1) { - s=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2])) - } - zz=s - } - return z -} - -// ***************************************** -// DISTRIBUTED SHAPE (DSHAPE) -// ***************************************** -type _distrb(extent:extent,dist:distr or null) -type _distrb(extent:extent,dist:distr) is ...,dshape(extent,dist) -type _distrb(extent:extent,dist:null) is ...,mshape(extent) -type shape(extent:extent,dist:distr or null) is _distrb(extent,dist) -type shape1d(extent:extent1d,dist:distr or null) is shape(extent,dist) -type shape2d(extent:extent2d,dist:distr or null) is shape(extent,dist) -type shape3d(extent:extent3d,dist:distr or null) is shape(extent,dist) -type shape4d(extent:extent4d,dist:distr or null) is shape(extent,dist) -type shape5d(extent:extent5d,dist:distr or null) is shape(extent,dist) -type shape6d(extent:extent6d,dist:distr or null) is shape(extent,dist) -type shape7d(extent:extent7d,dist:distr or null) is shape(extent,dist) -type PM__distr_tag is unique -type dshape(extent:extent,dist:distr) is rec {use _mshape:mshape(extent),dist:dist,_tile,_tilesz,_size:int,_level:int,_dtag:PM__distr_tag} -proc check_conform(x:dshape,y:mshape) { - check_conform(x._mshape,y) -} - -proc check_conform(x:mshape,y:dshape) { - test "A distributed object connot conform to a non-distributed value" => fix(false) -} - -proc check_conform(x:dshape,y:dshape) { - check_conform(x._mshape,y._mshape) - test "Objects have different distributions"=> x.dist==y.dist -} - -proc conform(x:dshape,y:mshape)=conform(x._mshape,y) -proc conform(x:mshape,y:dshape)=fix(false) -proc conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist -proc _local_size(x:dshape)=size(x._tile) -// Get an element from a null tile - just pass index through -proc element(x:null,y:tuple(index))=y -proc element(x:null,y:int)=y -proc size(d:dshape)=d._size -proc dims(d:dshape)=dims(d._mshape._extent) -proc #(d:dshape)=new dshape{ - _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level,_dtag=d._dtag -} -proc [](d:dshape,s:index)=d._mshape._extent[s] -proc [](d:dshape,s:subs)=_dshape_slice(d,ss) where ss=fill_in(#d._mshape._extent,s,fix(true)){ - check_contains(#(d._mshape._extent),s) -} - -proc _dshape_slice(d:dshape,ss)=new dshape{ -_mshape=shape(#active_dims(ss)),dist=dist,_tile=tile,_tilesz=#tile,_size=size(tile),_level=d._level,_dtag=d._dtag} where tile=element(dist,_shrd_node()) where dist=sliced_distr(d.dist,ss) -// ***************************************** -// DISTRIBUTED ARRAY AND SHAPE TEMPLATES -// ***************************************** -type darray_template(e,d,p,t) is rec {_e:e,_d:d,_p:p,_t:t,_v} -type dshape_template(d,p,t) is rec {_d:d,_p:p,_t:t} -proc darray(e,d:extent)=array(e,d,VBLOCK) -proc array(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { - _e=e,_d=d,_p=distr,_t=topo,_v=fix(true) -} -proc array(e,d:extent,distr:null or tuple(null))=array(e,d) -proc dvarray(e,d:extent)=varray(e,d,VBLOCK) -proc varray(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { - _e=e,_d=d,_p=distr,_t=topo,_v=fix(true) -} -proc varray(e,d:extent,distr:null or tuple(null))=varray(e,d) -proc shape(d:extent,distr,topo:any=null)=new dshape_template { - _d=d,_p=distr,_t=topo -} -// ***************************************** -// DISTRIBUTED ARRAYS -// ***************************************** -proc PM__dup(d:darray_template) { - dd=dims(d._d) - topo=topology(d._t,d._p,dd, min(size(d._d),shrd_nnode())) - dist=distribute(d._p,dd,topo) - test "Not enough processors to implement distribution"=> size(#dist)<=shrd_nnode() - p=_shrd_node() - var elem=empty(dist) - if p size(#dist)<=shrd_nnode() - p=_shrd_node() - var elem=empty(dist) - if p fix(false) -proc _arb(dd:any^dshape)=_get_aelem(dd,0) -proc dims(dd:any^dshape)=dims((#dd)._mshape) -proc PM__redim(a,d)=_redim(a,d) -proc PM__local(a:any^dshape)=_redim(a,(#a)._tilesz) -proc PM__local(a:any^mshape)=a -proc PM__local%(x:shrd) shrd =PM__local(x) -proc element(a:any^dshape,t) { - p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) - var r=_arb(a) - if p==_this_node():r=_get_aelem(a,i) - _bcast_shrd(&r,p) - return r -} - -proc _set_elem(&a:any^dshape,v,t) { - p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) - if p==_this_node():PM__setaelem(&a,i,v) -} - -// ************************************************* -// SLICES -// ************************************************* -// Slices -type array_slice(a,s) is struct^{_a:a,_s:s} -proc _arb(x:array_slice)=_arb(x._a) -proc #(x:array_slice)=#(x._s) -proc #(x:array_slice(any^dshape))=_dshape_slice(d,d._mshape._extent#x._s) where d=#(x._a) -proc conform(x:mshape,y:array_slice)=map_reduce($_conform,$and,x,y._s) -proc conform(x:dshape,y:array_slice)=map_reduce($_conform,$and,x._mshape,y._s) -proc conform(x,y:array_slice)=map_reduce($_conform,$and,#x,y._s) -proc dims(x:array_slice)=dims(x._s) -proc size(x:array_slice)=size(x._s) -proc element(x:array_slice(any^mshape,),y:index)=element(x._a,x._s[y]) -proc element(x:array_slice,y:subs)=new array_slice { - _a=x._a,_s=x._s[y] -} -proc _set_elem(&x:array_slice(any^mshape,),v,y:index) { - PM__setaelem(&^(x._a),index(#(x._a),x._s[y]),v) -} -proc PM__dup(x:array_slice(any^mshape,)){ - var a=array(_arb(x),#x) - a=x - return a -} -proc PM__dup(x:array_slice(any^dshape,)){ - d=#x._a - ss=(#x._a)._mshape#x._s - var a=array(_arb(x._a),_dshape_slice(d,ss)) - _set_slice(&^(PM__local(a)),#(#a)._tile, PM__local(x._a),overlap((#x._a)._tile,ss)) - return a -} -// ************************************************* -// ARRAY & SLICE ASSIGNMENT -// ************************************************* -proc PM__assign(&xx:farray,x:any) { - check_assign_types(_arb(xx),x) - _set_array(&xx,x) -} -proc PM__assign(&xx:farray,x:array) { - _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) -} -proc PM__assign(&xx:varray,x:any except varray) { - check_assign_types(_arb(xx),x) - _set_array(&xx,x) -} -proc PM__assign(&xx:varray,x:farray) { - _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) -} -proc PM__assign_var(&xx:farray,x:any) { - check_assign_types(_arb(xx),x) - _set_array(&xx,x) -} -proc PM__assign_var(&xx:farray,x:array) { - _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) -} -proc PM__assign_var(&xx:varray,x:any except varray) { - check_assign_types(_arb(xx),x) - _set_array(&xx,x) -} -proc PM__assign_var(&xx:varray,x:farray) { - _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) -} -proc PM__aliased_assign(&xx,x){ -} -proc PM__aliased_assign(&xx:array_slice,x:array_slice) <> { - _assign_internal_slice(&xx,x._s) -} -proc _array_assign(&xx,x,v:fix(false)){ - check_assign_types(_arb(xx),x) - _set_array(&xx,x) -} -proc _array_assign(&xx,x,v:fix(true)){ - check_conform(extent(#xx),extent(#x)) - if _copy_array(&xx,x):_sync_messages(xx,x) -} -proc _array_assign(&xx:array_slice,x:array_slice,v:fix(true)){ - check_conform(extent(#xx),extent(#x)) - if _copy_array(&xx,x):_sync_messages(xx,x) -} -proc _array_assign(&xx:varray,x,v:fix(true)) { - _assign_element(&xx,x) -} -proc _array_assign(&xx:varray,x:array_template,v:fix(true)) { - _assign_element(&xx,PM__dup(x)) -} -PM__if_compiling -proc _set_slice(&x,a,y,b) { - foreach i in a,j in b:x[i]=y[j] -} -PM__else -proc _set_slice(&x,a,y,b) { - if size(a)>0:forall i in a,j in b{ - sync x[i]=y[j] - } -} -PM__endif -type _non_d is any^mshape,array_slice(any^mshape,) -proc _set_array(&x:any^mshape,y){ - forall i in x { - _assign(&i,y) - } -} - -proc _set_array(&x:any^dshape,y){ - _set_array(&^(PM__local(^(&x))),y) -} -proc _set_array(&x:array_slice(any^mshape,),y){ - forall i in x._s { - _set_elem(&x._a,y,i <>) - } -} -proc _set_array(&x:array_slice(any^dshape,),y){ - tile=(#x._a)._tile - t=overlap(tile,((#x._a)#x._s)) - forall i in t { - _set_elem(&x._a,y,i <>) - } -} - -proc _copy_array(&a:_non_d,b:_non_d){ - forall i in a, j in b { - i=j - } - return fix(false) -} -proc _copy_array(&xx:any^dshape,x:_non_d) { - tile=(#xx)._tile - forall i in tile { - PM__setaelem(&xx,index(dims(tile),here),x[(#x)[i]] <>) - } - return fix(false) -} -proc _copy_array(&xx:array_slice(any^dshape,),x:_non_d) { - tile=(#xx._a)._tile - subtile,subarray=overlap(tile,(#xx._a)._mshape#xx._s) - forall i in subtile,j in subarray { - PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <>) - } - return fix(false) -} - -proc _copy_array(&a:_non_d,x:any^dshape) { - dist=(#x).dist - foreach p in #(dist) { - tile=element(dist,p) - i=index(dims(dist),p) - if i==_shrd_node() { - forall kk in PM__local(x),j in tile { - var k=kk - _bcast_shrd(&k,i) - _set_elem(&a,k,(#a)[j] <>) - } - } else { - forall j in tile { - var k=_arb(a) - _bcast_shrd(&k,i) - _set_elem(&a,k,(#a)[j] <>) - } - } - } - return fix(false) -} - -proc _copy_array(&v:_non_d,x:array_slice(any^dshape,)) { - dist=(#(x._a)).dist - xs=(#(x._a))._mshape#x._s - nodes=#dist - foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) { - p=nodes[pp] - utile,elem=overlap(dist[nodes[p]],xs) - i=index(dims(dist),p) - if i==_shrd_node() { - forall j in utile, jj in elem { - var k=element(PM__local(x._a),j) - _bcast_shrd(&k,i) - _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>) - } - } else { - forall j in elem { - var k=_arb(x._a) - _bcast_shrd(&k,i) - _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>) - } - } - } - return fix(false) -} - -proc _copy_array(&x:any^mshape,y:array_template) { - _set_array(&x,y._a) - return fix(false) -} -proc _copy_array(&x:any^dshape,y:array_template) { - _set_array(&^(PM__local(^(&x))),y._a) - return fix(false) -} -type _comp is contains(array or *any or PM__anyref(,,,,)) -proc _copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) { - _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#(xx._a),xd=#(x._a) - return fix(true) -} - -proc _copy_array(&xx:any^dshape,x:array_slice(any^dshape)) { - _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#xx,xd=#(x._a) - return fix(true) -} - -proc _copy_array(&xx:array_slice(any^dshape,),x:any^dshape) { - _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#(xx._a),xd=#x - return fix(true) -} - -proc _copy_array(&xx:any^dshape,x:any^dshape) { - _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#xx,xd=#x - return fix(true) -} - -proc _assign_internal_slice(&xx:array_slice(any^mshape),s) { - x=new array_slice{ - _a=xx._a,_s=s - } - xx=x -} -proc _assign_internal_slice(&xx:array_slice(any^dshape),s) { - xxd=#(xx._a) - xxs=xxd._mshape#xx._s - xs=xxd._mshape#s - ltile=intersect(xxd._tile,xs) - ls=#ltile - var x=array(_arb(xx),ls) - _set_slice(&x,ls,PM__local(xx._a),overlap(xxd._tile,ltile)) - _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxs, x,xxd,xxd._mshape#s,ltile) -} - -proc _copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) { - _push_node_dist() - oldpart,oldtile=overlap(xs,oldd._tile) - newpart,newtile=overlap(xxs,newd._tile) - if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { - p=index(dims(oldd.dist),pp) - if p/=_this_node() { - tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) - ov=overlap(newd._tile,tile) - if size(ov)>0:_recv_slice(p,&xx,ov) - } - } - if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { - p=index(dims(newd.dist),pp) - if p/=_this_node() { - tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) - ov=overlap(otile,tile) - if size(ov)>0:_send_slice(p,x,ov) - } - } - if size(newpart)>0 and size(oldpart)>0 { - oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) - _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) - } - PM__pop_node(newd) -} - -proc _copy_darray_slice(&xx:_comp^any,newd,xxs,x,oldd,xs,otile) { - _push_node_dist() - oldpart,oldtile=overlap(xs,oldd._tile) - newpart,newtile=overlap(xxs,newd._tile) - if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { - p=index(dims(newd.dist),pp) - if p/=_this_node() { - tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) - ov=overlap(otile,tile) - if size(ov)>0:_send_slice(p,x,ov) - } - } - if size(newpart)>0 and size(oldpart)>0 { - oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) - _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) - } - if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { - p=index(dims(oldd.dist),pp) - if p/=_this_node() { - tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) - ov=overlap(newd._tile,tile) - if size(ov)>0:_recv_slice_sync(p,&xx,ov) - } - } - PM__pop_node(newd) -} - -proc _xp(x:single_point,y)=single_point(low(y)) -proc _xp(x,y)=y -// ************************************************* -// REFERENCES (SUBSCRIPTS AND SLICES) -// ************************************************* -// Reference type for & args -type PM__reftype(x) is x,PM__drefi(x,,,,) -// Support for internal ^(...) reference type -PM__intrinsic _v1(x:any)->(PM__d1 x) : "elem"(1) -PM__intrinsic _v2(x:any)->(PM__d2 x) : "elem"(2) -PM__intrinsic _v3(x:any)->(PM__d3 x) : "elem"(3) -PM__intrinsic _v4(x:any)->(PM__d4 x) : "elem"(4) -PM__intrinsic _v5(x:any)->(PM__d5 x) : "elem"(5) -PM__intrinsic _v1%(r:any,s:any,h:any,x:any)->(PM__d1% x) : "elem"(1) -PM__intrinsic _v2%(r:any,s:any,h:any,x:any)->(PM__d2% x) : "elem"(2) -PM__intrinsic _v3%(r:any,s:any,h:any,x:any)->(PM__d3% x) : "elem"(3) -PM__intrinsic _v4%(r:any,s:any,h:any,x:any)->(PM__d4% x) : "elem"(4) -PM__intrinsic _v5%(r:any,s:any,h:any,x:any)->(PM__d5% x) : "elem"(5) -// Right hand side references -proc _make_null(x)=null -proc PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) -proc PM__subref(x,t:subs){ - tt=_tup(t) - check_contains(#x,tt) - return _subref(x,tt) -} -proc PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x)) -proc PM__subref(x:PM__anyref(,,,,),t:null)=PM__subref(x,map($_make_null,#_v1(x))) -proc _subref(x:any^mshape,t:index)=element(x,t) -proc _subref(x:any^any,t:subs)=new array_slice { - _a=x,_s=fill_in(#x,t,fix(true)) -} -proc _subref(x:array_slice(any^mshape,),t:index)=element(x._a,x._s[t]) -proc _subref(x:array_slice,t:subs)=new array_slice { - _a=x._a,_s=x._s[t] -} -proc _subref(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) -proc _subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t]) -proc _subref(a:PM__anyref(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) -proc _subref(a,t)=$[](a,t) -proc [](a:array,...)=PM__getref(PM__subref(a,_tup(...))) -// Left hand side references -proc PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) -proc PM__sublhsamp(x,t:subs) { - tt=_tup(t) - check_contains(#x,tt) - return _sublhs(x,tt) -} -proc PM__sublhsamp(x:any^dshape,t:subs) { - test "Cannot have subscript of a distributed array in ""&"" argument"=>fix(false) - return _arb(x) -} - -proc PM__sublhs(x,t)=error_type() check "Incorrect type in subscript"=>fix(false) -proc PM__sublhs(x,t:subs) { - tt=_tup(t) - check_contains(#x,tt) - return _sublhs(x,tt) -} -proc PM__sublhs(x:PM__ref(,,,,),t:subs) { - tt=_tup(t) - return _sublhs(x,tt) -} -proc PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x)) -proc PM__sublhs(x:PM__ref(,,,,),t:null)=PM__sublhs(x,map($_make_null,#_v1(x))) -proc _sublhs(x:any^mshape,t:index)=_make_subref(x,t) -proc _sublhs(x:any^any,t:subs)=new array_slice { - _a=x,_s=fill_in(#x,t,fix(true)) -} -proc _sublhs(x:array_slice(any^mshape,),t:index)=_make_subref(x._a,x._s[t]) -proc _sublhs(x:array_slice,t:subs)=new array_slice { - _a=x._a,_s=x._s[t] -} -proc _sublhs(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) -proc _sublhs(a:PM__ref(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) -proc [](&a:array,v,...){ - PM__assign(&^(PM__sublhs(^(&a),_tup(...))),v) -} - -*/ - -// Realise a reference -proc PM__valref(x)=x - -/* -proc PM__valref(x:PM__anyref(,,,,)) { - var v=_v1(x) - if _v4(x)==_shrd_node() { - v=_getref(x,null) - } - _bcast_shrd(&v,_v4(x)) - return v -} - -// Assign to a reference -proc PM__assign(&x:PM__anyref(,,,,),y) { - check_assign_types(_v1(^(&x)),y) - if _v4(^(&x))==_shrd_node() { - PM__assign(&^(_getlhs(^(&x),null)),y) - } -} - -proc PM__assign(&x:PM__anyref(,,,,),y,p:assignment_operator) { - if _v4(^(&x))==_shrd_node() { - PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) - } -} - -// ************************************************************* -// DISTRIBUTED REFERENCES -// ************************************************************* -// Distributed reference is an internal compiler type -// ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode) -// mode is: -// null -- local reference -// _s_ref -- shrd index on darray, only shrd/indexed otherwise -// _sp_ref -- shrd index on darray, some priv after (or before) -// _d_ref -- indexed index on darray, shrd/indexed otherwise -// _dp_ref -- indexed index on darray, some priv after (or before) -// _p_ref -- priv index on darray and possibly elsewhere -type _s_ref is unique -type _sp_ref is unique -type _d_ref is unique -type _dp_ref is unique -type _p_ref is unique -PM__intrinsic _import_dref%(r:any,s:any,h:any,x:any)->(^^x) : "import_dref" -// Some trivial referencing cases -proc PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t) -proc PM__sublhsamp%(x:any^dshape,t:subs) { - test "Cannot have subscript of a distributed array in ""&"" argument"=>fix(false) - return _arb(x) -} - -proc PM__sublhs%(x,y)=PM__subref%(x,y) -proc PM__sublhs%(x:priv PM__anyref(,,,,),y)=PM__subref%(x,y) -proc PM__sublhs%(x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>fix(false) -proc PM__subref%(x:priv,y)=PM__subref(x,y) -proc PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y) -proc PM__subref%(x:priv,y:invar indexed)=PM__subref(x,*y) -proc PM__subref%(region:mshape,x:invar any^mshape,y:index)=PM__subref(x,y) -proc PM__subref%(region:mshape,x:invar any^mshape,y:subs)=PM__subref(x,y) -proc PM__subref%(region:mshape,x:invar any^mshape,y:invar indexed)=PM__subref(x,_dmap(y,here)) -proc PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>fix(false) -proc PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y) -proc PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y) -proc PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y)) -// Reference of non-distributed array with priv or indexed subscript -proc PM__subref%(x:invar any^mshape,t:index){ - tt=_tup(t) - check_contains(#x,tt) - i=index(#x,tt) - return PM__dref(_get_aelem(x,i),x,i,null,null) -} -proc PM__subref%(x:invar any^mshape,t:subs){ - tt=_tup(t) - check_contains(#x,tt) - return PM__drefs(x,x,tt,null,null) -} -proc PM__subref%(x:invar any^mshape,t:invar indexed)=PM__subref%(x,_dmap(t,here)) -proc PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t]) -proc PM__subref%(x,t)=PM__dref($[](x,t),x,t,null,null) -// Subscript or slice of distributed array -proc PM__subref%(x:shrd any^dshape,t:invar index) complete <>{ - tt=_tup(t) - check_contains(#(x),tt) - return PM__dref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) -} -proc PM__subref%(x:shrd any^dshape,t:index){ - tt=_tup(t) - check_contains(#(x),tt) - return PM__dref(_arb(x),x,i,p,_p_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) -} -proc PM__subref%(x:shrd any^dshape,t:subs){ - tt=_tup(t) - check_contains(#(x),tt) - var xx=varray(_arb(x),empty(#x)) - return PM__drefs(xx,x,tt,p,_p_ref) where p=nodes_for_grid((#x).dist,tt) -} -proc PM__subref%(x:shrd any^dshape,t:invar indexed) cond =PM__subref%(x,*t) -proc PM__subref%(region:shape(,blocked_distr),x:shrd any^dshape(,blocked_distr),t:invar indexed) uncond { - check_contains(#x,_dmap(t,here)) - return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t) -} -proc PM__subref%(x:shrd any^dshape,t:invar indexed) uncond =PM__subref%(x,*t) -// Subscript or slice of non-distristuted array which is itself result of variant slice -proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:index){ - tt=_tup(t) - check_contains(#_v1%(x),tt) - i=index(#(_v1%(x)),tt)return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null) -} -proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:invar index){ - tt=_tup%(t) - check_contains(#_v1%(x),tt) - i=index(#(_v1%(x)),tt) - return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null) -} -proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:subs) { - tt=_tup(t) - check_contains(#(_v1%(x)),tt) - return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null) -} -proc PM__subref%(x:priv PM__anyref(any^mshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) -// Subscript or slice of darray which is itself the result of a priv subscript -proc PM__subref%(x:priv PM__anyref(any^dshape,,,null,null),t:index){ - tt=_tup(t) - check_contains(#_v1%(x),tt) - return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt) -} -proc PM__subref%(x:priv PM__anyref(any^dshape,,,null,null),t:subs){ - tt=_tup(t) - check_contains(#_v1%(x),tt) - return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) where p=nodes_for_grid((#_v1%(x)).dist,tt) -} -proc PM__subref%(x:priv PM__anyref(any^dshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) -// Subscript of a priv slice -proc PM__subref%(x:priv PM__drefs(,,,null,null),t:subs)=PM__subref%(_v2%(x),_v3%(x)[_tup(t)]) -proc PM__subref%(x:priv PM__drefs(,,,null,null),t:invar indexed)=PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here) -// Subscript of distributed reference -proc _arb%(x:partial)=_arb(x) -proc _arb%(x:complete) complete <>=_arb(x) -proc _arb%(x:chan) complete <>=_arb(x) -proc _arb%(x:invar) complete <>=_arb(x) -proc PM__subref%(x:priv PM__anyref(any^any,,,,),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) -proc PM__subref%(x:priv PM__anyref(any^any,,,,),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t)) -proc PM__subref%(x:priv PM__anyref(any^any,,,,_s_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref) -proc PM__subref%(x:priv PM__anyref(any^any,,,,),t:invar indexed)=PM__subref%(x,_dmap(_tup(t),here)) -proc PM__subref%(x:priv PM__anyref(any^any,,,,_s_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) -proc PM__subref%(x:priv PM__anyref(any^any,,,,_d_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) -proc PM__subref%(x:priv PM__anyref(any^any,,,,_d_ref),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) -proc PM__subref%(x:priv PM__anyref(any^any,,,,_d_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref) -// Node .[] subscript of distributed array -type _lcl is unique{_LCL} -proc PM__nodelhs%(x,y)=PM__noderef%(x,y) -proc PM__noderef%(region:dshape,x:shrd any^dshape,y:invar null)=^(PM__import_val(PM__local(x)),coherent) -proc PM__noderef%(region:dshape,x:shrd any^dshape,y:invar any_int){ - xd=#((#x).dist) - check_contains(xd,y) - return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)where p=index(xd,int(y)) -} -proc PM__noderef%(region:dshape,x:shrd any^dshape,y:priv any_int){ - xd=#((#x).dist) - check_contains(xd,y) - return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)where p=index(xd,y) -} -proc PM__noderef%(region:dshape,x:shrd any^dshape,y:shrd indexed)=PM__noderef%(x,*y) -proc PM__noderef%(x:priv PM__anyref(any^dshape,,,null,null),y:invar any_int){ - xd=#((#x).dist) - check_contains(xd,y) - return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)where p=index(xd,int(y)) -} -proc PM__noderef%(x:priv PM__anyref(any^dshape,,,null,null),y:priv any_int){ - xd=#((#x).dist) - check_contains(xd,y) - return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)where p=index(xd,int(y)) -} -proc PM__noderef%(x:priv PM__anyref(any^dshape,,,null,null),y:shrd indexed)=PM__noderef%(x,*y) -proc PM__noderef%(x,y)=error_type() { - if not region is { - test """.[]"" subscript in non-distributed region"=>fix(false)} elseif x is { - test """.[]"" subscript cannot be applied to a mirrored array"=>fix(false)} elseif not x is { - test """.[]"" subscript applied to a non-array"=>fix(false)} elseif not y is { - test """.[]"" subscript must have an integer value"=>fix(false)} else { - test "Incorrect "".[]"" subscript"=>fix(false) - } -} - -// May need to cap off reference with here -type _here(t) is rec {here:t} -proc _cap%(x,h)<>=x -proc _cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here { - here=h -} -) -proc _capn%(x,h)<>=PM__dref(_v1%(x),x,new _here { - here=h -} -) -// Treat ! variables differently only for limited circumstances in drefs -proc _drat(at,tile,t)=fix(false) -proc _drat(at:fix(true),tile:tuple(range or block_seq),t:indexed and _dr)=fix(true) -type _di(n) is indexed_dim(fix(1),fix(1),,n) or int -type _dr is [_di(fix(1))],[_di(fix(1)),_di(fix(2))],[_di(fix(1)),_di(fix(2)),_di(fix(3))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5)),_di(fix(6))],[_di(fix(1)),_di(fix(2)),_di(fix(3)),_di(fix(4)),_di(fix(5)),_di(fix(6)),_di(fix(7))] -// Resolve a distributed reference -proc PM__getref%(x,at)=x -proc PM__getref%(x:priv PM__anyref(,,,null,null),at)=_v1%(x) -proc PM__getref%(x:priv PM__anyref(,,,int,_p_ref),at) { - PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) - return v -} -proc PM__getref%(x:priv PM__anyref(,,,int,_sp_ref),at) { - PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) - return v -} -proc _scatter(x,region) { - if _this_node()==_v4(x):foreach node in #region.dist { - d=#region._mshape - a={ - _getref(_import_dref%(x),j): j in d - } - p=index(dims(region.dist),node) - _send_slice(p,a,region.dist[node]) - } -} - -proc PM__getref%(x:complete PM__anyref(,,,int,_s_ref),at:invar) complete <> { - chan var xx=_v1%(x) - _getref_s%(&xx!,^^(x),at) - _bcast_shrd(&xx) - return xx -} -proc _getref_s%(&xx:invar,x:invar,at:invar) PM__node { - PM__head_node{ - _irecv(_v4(x),&xx) - } - _scatter(x,region) - _sync_messages(xx,x) -} -proc PM__getref%(x:complete PM__anyref(_comp,,,int,_s_ref),at:invar) complete <>{ - chan var xx=_v1%(x) - _getref_sc%(&xx!,^^(x),at) - _bcast_shrd(&xx) - return xx -} -proc _getref_sc%(&xx:invar,x:invar,at:invar) PM__node { - _scatter(x,region) - PM__head_node{ - _recv(_v4(x),&xx) - } - _sync_messages(xx,x) -} -proc PM__getref%(x:complete PM__anyref(,PM__anyref(,,,,),,,_d_ref),at:invar) complete <> { - chan var a=_v1%(x) - _getref_d%(&^(PM__local%(^(&a!))),^^(x),at <>) - _bcast_shrd(&a) - return a -} - -proc _getref_d%(&a:invar,x:invar,at:invar) PM__node { - _get_dindex_from_dref(&a,x,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) -} -proc PM__getref%(x:complete PM__anyref(,,,,_d_ref),at:invar) complete <> { - chan var a=_arb(_v2%(x)) - _getref_dc%(&a!,^^(x),at <>) - _bcast_shrd(&a) - return a -} -proc _getref_dc%(&a:invar,x:invar,at:invar) PM__node { - PM__head_node{ - _get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) - } -} - -proc PM__getref%(x:complete PM__anyref(,,,,_dp_ref),at:invar) complete <> { - chan var a=_v1%(x) - _getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>) - _bcast_shrd(&a) - return a -} -proc _getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node { - PM__head_node{ - _get_dindex_from_ref(&a,x,t.2, _local_region(region._tile,subregion(schedule)),region, t.1,atq,_drat(at,region._tile,t.1)) - } -} -proc PM__getref%(x:priv PM__drefs(,,,,),at) { - var v=varray(_arb(_v1%(x)),#_v3%(x)) - var vv=varray(_arb(_v1%(x)),empty(#_v1%(x))) - foreach p in _v4%(x) { - dist=(#(_getref(_v2%(x),null))).dist - u=overlap(_v3%(x),dist[p]) - ppp=index(dims(dist),p) - PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null) - v[u]=vvv - } - return v -} - -// Resolve reference locally (once communicated) -proc _getref_elem(x:any^mshape,i)=_get_aelem(x,i) -proc _getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i) -proc _getref(x:PM__anyref(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x)) -proc _getref(x:PM__anyref(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here) -proc _getref(x:PM__anyref(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)] -proc _getref(x:PM__anyref(,,null,,),y)<>=_getref(_v2(x),y) -proc _getref(x:PM__anyref(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y)) -proc _getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x) -proc _getref(x:PM__drefi(,null,null,null,null),y)<>=_v1(x) -proc _getref(x:PM__drefs(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x)) -proc _getslice(x:any^dshape,tt) { - t=overlap((#x)._tile,tt) - var v=varray(_arb(x),#t) - v=PM__local(x)[t] - return v -} -proc _getslice(x:any^mshape,t) { - var v=varray(_arb(x),#t) - v=x[t] - return v -} -proc _getref(x:any^any,y)=x -proc _getref(x:PM__drefi(,,indexed,,),y)<>=_getref(_v2(x),y)[_dmap(_v3(x),y)] -proc _getref(x:PM__drefi(,any^dshape,indexed,,),y)<>=element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) -proc _getref(x:PM__drefi(,,indexed,,),y:null)<>=_v1(x) :test "Internal error - uncapped dref" => fix(false) -PM__if_compiling -PM__intrinsic _sync%(any,any,any,&x:any): "sync" -PM__else -proc _sync%(&x:any){ -} -PM__endif -// Assignment of distributed and/or shrd or uniform references -proc PM__assign%(&x:priv,y,at) { - _sync%(&x) - PM__assign(&x,y <>) -} -proc PM__assign%(&x:invar,y,at) { - _sync%(&x) - _assign_to_invar%(&x,y) -} -proc _assign_to_invar%(&x:uniform,y:invar) complete { - PM__assign(&x,y <>) -} - -proc _assign_to_invar%(&x:shrd,y:invar) shrd{ - PM__assign(&x,y) -} - -proc _assign_to_invar%(&x:invar,y:priv) { - test "Can only assign an ""invar"" value to an ""invar"" variable" => fix(false) -} - -proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y,at) { - PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { - PM__assign(&^(_getlhs(^(&xx),null)),yy) - } - PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,fix(false) { - test "Cannot assign element twice in same assignment"=> _getref(xx,null)==yy - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y:invar,at) { - PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { - PM__assign(&^(_getlhs(^(&xx),null)),y) - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,null,null),y,at) { - foreach invar p in 0..size(#region.dist)-1 { - PM__bcast xx,yy,_cap%(x,here),y,p { - PM__assign(&^(_getlhs(^(&xx),null)),yy) - } - } - foreach invar p in 0..size(#region.dist)-1 { - PM__bcast xx,yy,_cap%(x,here),y,p { - test "Cannot assign an element two different values in a single assignment"=> _getref(xx,null)==yy - } - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,null,null),y:invar,at) { - _sync%(&x) - var xx=_import_dref%(x) - PM__assign(&^(_getlhs(^(&xx),here)),y) -} -proc PM__assign%(&x:priv PM__anyref(,null,null,null,null),y:invar,at) { - _sync%(&x) - PM__assign(&^(_v1%(^(&x))),y) -} -proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref or _s_ref),y,at) { - PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { - PM__assign(&^(_getlhs(^(&xx),null)),yy) - } - PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,fix(false) { - test "Cannot assign element to two different values in same assignment"=> _getref(xx,null)==yy - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref or _s_ref),y:invar,at) { - PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { - PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y)) - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,,_d_ref or _dp_ref),y,at) { - _set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)), $_just_assign,^^(^??),at,_v4(x) <>) -} -*/ -proc _just_assign(x,y)=y -/* -proc _set_ref_dp%(&x:invar,y:invar, prc:invar,atq:invar,at:invar,t:invar) PM__node { - _set_dindex_of_ref(&x,y,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,prc,atq,at) -} - -// Operater assignment: x =y -proc PM__assign%(&x:priv,y:priv,pr,at) { - PM__assign(&x,y,pr) -} -proc PM__assign%(&x:priv,y:invar,pr,at) { - PM__assign(&x,y,pr) -} -proc PM__assign%(&x:invar,y,pr,at) { - _assign_to_invar%(&x,y,pr,at) -} - -proc _assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete{ - PM__assign(&x,y,pr <>) -} - -proc _assign_to_invar%(&x:shrd,y:invar,pr:uniform,at:uniform) shrd { - PM__assign(&x,y,pr) -} - -proc _assign_to_invar%(&x:invar,y:priv,pr,at){ - _assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at) -} -proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y,pr,at) { - PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { - PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,int,_p_ref),y:invar,pr,at) { - PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { - PM__assign(&^(_getlhs(^(&xx),null)),y,pr) - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,null,null),y:priv,pr,at) { - foreach invar p in 0..size(region.dist)-1 { - PM__bcast xx,yy,_cap%(x,here),y,p { - PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) - } - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,null,null),y:invar,pr,at) { - var xx=_import_dref%(x) - PM__assign(&^(_getlhs(^(&xx),here)),y,pr) -} -proc PM__assign%(&x:priv PM__anyref(,null,null,null,null),y:invar,pr,at) { - PM__assign(&^(_v1%(^(&x))),y,pr) -} -proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref or _s_ref),y:priv,pr,at) { - PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { - PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,int,_sp_ref),y:invar,pr,at) { - PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { - PM__assign(&^(_getlhs(^(&xx),null)),y,pr) - } -} - -proc PM__assign%(&x:priv PM__anyref(,,,,_d_ref or _dp_ref),y:priv,pr,at) { - _set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,pr,^^(^??),at <>)where t=_v4%(x) -} -// Resolve LHS reference (locally after communication) -proc _getlhs(x:PM__anyref(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here) -proc _getlhs(x:PM__anyref(,,_lcl,,),y)=_getlhs(_v2(x),y) -proc _getlhs(x:PM__dref(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) -proc _getlhs(x:PM__drefi(,,null,,),y)=_getlhs(_v2(x),y) -proc _getlhs(x:PM__drefi(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) -proc _getlhs(x:PM__dref(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) -proc _getlhs(x:PM__drefi(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) -proc _local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t)) -proc _getlhs(x:PM__drefs(,,subs,,),y)<>=_local_ref(x,_v3(x)) -proc _getlhs(x:PM__dref_is(,,subs,,),y)<>=_local_ref(x,_v3(x)) -proc _getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x) -proc _getlhs(x:PM__drefi(,null,null,null,null),y)<>=_v1(x) -proc _getlhs(x:PM__dref(,null,null,null,null),y)<>=_v1(x) -proc _getlhs(x:any^any,y)=x -proc _getlhs(x:any^dshape,y)=PM__local(x) -proc _getlhs(x:PM__drefi(,,indexed,,),y)<>=_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y)) -proc _getlhs(x:PM__drefi(,any^dshape,indexed,,),y)<>=_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) -proc _getlhs(x:PM__drefi(,,indexed,,),y:null)=_v1(x) :test "Internal error -- uncapped indexed ref" => fix(false) -// ************************************************************** -// INDEXED VARIABLES -// ************************************************************** -type indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m=fix(1),_c:c=fix(0),_d:d=fix(1),_n:n} -type indexed(t:int) is tuple(indexed_dim or int) except tuple(int) -proc PM__makeidxdim(x:null,y)=new indexed_dim { - _n=y -} -proc PM__makeidxdim(x:null)=new indexed_dim { - _n=null -} -proc PM__makeidxdim(x:range,y)=new indexed_dim { - _c=x._lo,_n=y -} -proc PM__makeidxdim(x:strided_range,y)=new indexed_dim { - _c=x._lo,_m=x._st,_n=y -} -proc PM__makeidxdim(x,y)=PM__makeidxdim(get_dim(x,y),y) -proc PM__makeidxdim(x:tuple)=map($PM__makeidxdim,x,indices(x)) -proc PM__makeidxdim(x:seq)=[PM__makeidxdim(x,fix(1))] -proc PM__makeidx(x:indexed_dim or indexed)=new _indexed { - _t=_tup(x),_r=null -} -proc PM__makeidx(x:indexed_dim or indexed,y)=new _indexed { - _t=_tup(x),_r=y -} -proc PM__makeidx(x,y)=x :test "Malformed indexed expression" => fix(false) -proc PM__makeidx(x)=x :test "Malformed indexed expression" => fix(false) -proc *%(x:indexed)=_dmap(x,here) -proc *%(x)=here check"""*"" operator can only be applied to an ""indexed"" value"=>fix(false) -proc *(x)=x check"""*"" operator cannot be applied outside of a parallel context"=>fix(false) -proc +(x:indexed_dim,yy:any_int)=new indexed_dim { -_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) -proc +(yy:any_int,x:indexed_dim)=new indexed_dim { -_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) -proc -(x:indexed_dim,yy:any_int)=new indexed_dim { -_m=x._m,_c=x._c-y*x._d,_d=x._d,_n=x._n} where y=int(yy) -proc -(yy:any_int,x:indexed_dim)=new indexed_dim { -_m=-x._m,_c=-x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) -proc *(x:indexed_dim,yy:any_int)=new indexed_dim { -_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) -proc *(yy:any_int,x:indexed_dim)=new indexed_dim { -_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) -proc /(x:indexed_dim,yy:any_int)=new indexed_dim { -_m=x._m,_c=x._c,_d=x._d*y,_n=x._n} where y=int(yy) -proc +(x:indexed_dim,y:indexed_dim)=new indexed_dim { - _m=x._m*y._d+y._m*x._d,_c=x._c*y._d+y._c*x._d,_d=x._d*y._d,_n=x._n -} -proc -(x:indexed_dim,y:indexed_dim)=new indexed_dim { - _m=x._m*y._d-y._m*x._d,_c=x._c*y._d-y._c*x._d,_d=x._d*y._d,_n=x._n -} -proc string(x:indexed_dim)="($here."++x._n++"*"++x._m++"+"++x._c++")/"++x._d -proc string(x:indexed_dim(fix(1)))="$here."++x._n++"*"++x._m++"+"++x._c -proc string(x:indexed_dim(fix(1),fix(1)))="$here."++x._n++"+"++x._c -proc string(x:indexed_dim(fix(1),fix(1),fix(0)))="$here."++x._n -proc _correct(x:indexed,y:extent)=map($-,x,low(y)) -proc _dmap(x:any_int,n:int)=x -proc _dmap(x:any_int,n:grid_slice_dim)=single_point(x) -proc _dmap(x:any_int,n:tuple(int))=x -proc _dmap(x:any_int,n:tuple(grid_slice_dim))=single_point(x) -proc _dmap(x:indexed_dim,n:int)=(n*x._m+x._c)/x._d -proc _dmap(x:indexed_dim,n:tuple)=_dmap(x,get_dim(n,x._n)) -proc _dmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi)where lo=_dmap(x,low(n)),hi=_dmap(x,high(n)) -proc _dmap(x:indexed_dim(fix(1),fix(1)),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st -proc _dmap(x:indexed_dim(fix(1),fix(1)),n:block_seq)=block_seq(n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) -proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)=map_const($_dmap,x,n) -proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)=s#map_const($_dmap,x,n) -type _round_up is unique -type _round_down is unique -proc _dunmap(x:indexed_dim,n:null)=null -proc _dunmap(x:indexed_dim,n:int,r:_round_down)=(n*x._d-x._c)/x._m -proc _dunmap(x:indexed_dim,n:int,r:_round_up)=(n*x._d+x._m-sign(1,x._m)-x._c)/x._m -proc _dunmap(x:indexed_dim,n:tuple)=_dunmap(get_dim(n,x._n),x) -proc _dunmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up) -proc _dun(x:indexed_dim,m,n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m))) -proc _dun(x:int,m,n:extent)=n -proc _dunmap(x:indexed,m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n) -proc _dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,n) -// Given tile and global region (which may be null) compute local region -proc _local_region(t,r:null)=t -proc _local_region(t,r)=intersect(t,r) -proc _root_node(at:fix(true))=_root_node() -proc _root_node(at:fix(false))=_this_node() -// Resolve x[indexed] -proc _get_dindex(&a,x,shapex,local_tile,local_region,t:indexed,at) { - tt=_correct(t,shapex._mshape) - if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) { - if at or a is <_comp^any> { - _get_dindex_ss(&a,x,shapex,local_tile,local_region,tt,at) - } else { - _get_dindex_s(&a,x,shapex,local_tile,local_region,tt,at) - } - } else { - if at or a is <_comp^any> { - _get_dindex_rs(&a,x,shapex,local_tile,local_region,tt,at) - } else { - _get_dindex_r(&a,x,shapex,local_tile,local_region,tt,at) - } - } -} - -// Resolve x[indexed] for cases where size(x[indexed])>=size(region) -// -- in this case send one value for every point in current (sub)region -proc _get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { - PM__head_node{ - shapexx=#shapex._mshape - this_tile=shapex._tile - foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { - if contains(#(shapex.dist),p) { - i=index(dims(shapex.dist),p) - if i/=_this_node(){ - other_tile=element(shapex.dist,p) - dest_range2=_dunmap(t,other_tile,local_region._mshape) - portion_to_recv=overlap(local_tile,dest_range2) - if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) - } - } - } - dest_range=_dunmap(t,shapex._tile,local_region._mshape) - foreach p in nodes_for_grid(local_region.dist,dest_range){ - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(local_region.dist,p) - portion_to_recv=intersect(other_tile,dest_range) - if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) - } - } - } - _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) - _sync_messages(a,x) - } -} - -// Resolve x[indexed] for cases where size(x[indexed])<=size(region) -// -- in this case send those values in x which are needed to calculate x[indexed] -proc _get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { - shapexx=#shapex._mshape - src_range=_dmap(t,local_tile) - var b=array(_arb(a),#src_range) - foreach p in nodes_for_grid(shapex.dist,src_range) { - if contains(#(shapex.dist),p) { - i=index(dims(shapex.dist),p) - if i/=_this_node() { - other_tile=element(shapex.dist,p) - portion_to_send=overlap(src_range,other_tile) - if size(portion_to_send)>0:_recv_slice(i,&b,active_dims(src_range,portion_to_send)) - } - } - } - dest_range=_dunmap(t,shapex._tile,local_region._mshape) - foreach p in nodes_for_grid(local_region.dist,dest_range){ - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(local_region.dist,p) - src_range2=_dmap(t,other_tile) - portion_to_send=overlap(shapex._tile,src_range2) - if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) - } - } - } - u,v=overlap(src_range,shapex._tile) - forall i in u,j in v{ - _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) - } - _sync_messages(x,b) - _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) -} - -// Resolve x[indexed] for cases where size(x[indexed])>=size(region) -// -- in this case send one value for every point in current (sub)region -// -- Version for more complex types that need sync receive -proc _get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { - shapexx=#shapex._mshape - this_tile=shapex._tile - dest_range=_dunmap(t,shapex._tile,local_region._mshape) - foreach p in nodes_for_grid(local_region.dist,dest_range){ - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(local_region.dist,p) - portion_to_recv=intersect(other_tile,dest_range) - if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) - } - } - } - _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) - foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { - if contains(#(shapex.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(shapex.dist,p) - dest_range2=_dunmap(t,other_tile,local_region._mshape) - portion_to_recv=overlap(local_tile,dest_range2) - if size(portion_to_recv)>0 { - _recv_slice_sync(i,&a,portion_to_recv) - } - } - } - } - _sync_messages(a,x) -} - -// Resolve x[indexed] for cases where size(x[indexed])<=size(region) -// -- in this case send those values in x which are needed to calculate x[indexed] -// -- Version for more complex types that need sync receive -proc _get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) { - PM__head_node { - shapexx=#shapex._mshape - dest_range=_dunmap(t,shapex._tile,local_region._mshape) - foreach p in nodes_for_grid(local_region.dist,dest_range){ - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(local_region.dist,p) - src_range=_dmap(t,other_tile) - portion_to_send=overlap(shapex._tile,src_range) - if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) - } - } - } - } - src_range=_dmap(t,local_tile) - var b=array(_arb(a),#src_range) - if _head_node() or at { - u,v=overlap(src_range,shapex._tile) - forall i in u,j in v { - _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) - } - foreach p in nodes_for_grid(shapex.dist,src_range) { - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(shapex.dist,p) - portion_to_send=overlap(src_range,other_tile) - if size(portion_to_send)>0{ - PM__head_node{ - _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send)) - } - if at:_bcast_slice_shrd(&b,active_dims(src_range,portion_to_send)) - } - } - } - } - } - _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) - _sync_messages(x,b) -} - -proc _copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) { - u=overlap(a_tile,_dunmap(t,b_tile,a_extent)) - forall i in u { - j=b_tile#_dmap(t,a_tile[i]) - if j in #b_tile:_set_elem(&a,PM__getelem(b,j),i <>) - } -} - -proc _copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) { - u=intersect(a_tile,_dunmap(t,b_tile,a_extent)) - forall i in u { - bb=_import_dref%(b) - _set_elem(&a,_getref(bb,i),a_tile#i <>) - } -} - -// Resolve x[ indexed ][ indexed or shrd ] ... -proc _get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) { - t=_correct(tt,shapex._mshape) - shapexx=#shapex._mshape - this_tile=shapex._tile - dest_range=_dunmap(t,shapex._tile,local_region._mshape) - foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { - if contains(#(shapex.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node(){ - other_tile=element(shapex.dist,p) - dest_range2=_dunmap(t,other_tile,local_region._mshape) - portion_to_recv=overlap(local_tile,dest_range2) - if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) - } - } - } - nodes=nodes_for_grid(local_region.dist,dest_range) - var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) - foreach pp in #nodes { - p=nodes[pp] - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(local_region.dist,p) - portion_to_recv=intersect(other_tile,dest_range) - if size(portion_to_recv)>0 { - b[pp]={ - _getref(_import_dref%(x),h):h in portion_to_recv - } - _isend(i,b[pp]) - } - } - } - } - _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) - _sync_messages(a,x) -} - -// Resolve x[ indexed ][ indexed or shrd ] ... -proc _get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) { - t=_correct(tt,shapex._mshape) - shapexx=#shapex._mshape - this_tile=shapex._tile - dest_range=_dunmap(t,shapex._tile,local_region._mshape) - nodes=nodes_for_grid(local_region.dist,dest_range) - var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) - foreach pp in #nodes { - p=nodes[pp] - if contains(#(local_region.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node() { - other_tile=element(local_region.dist,p) - portion_to_recv=intersect(other_tile,dest_range) - if size(portion_to_recv)>0 { - b[pp]={ - _getref(_import_dref%(x),h):h in portion_to_recv - } - _isend(i,b[pp]) - } - } - } - } - _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) - foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { - if contains(#(shapex.dist),p) { - i=index(dims(local_region.dist),p) - if i/=_this_node(){ - other_tile=element(shapex.dist,p) - dest_range2=_dunmap(t,other_tile,local_region._mshape) - portion_to_recv=overlap(local_tile,dest_range2) - if size(portion_to_recv)>0{ - PM__head_node{ - _recv_slice_sync(i,&a,portion_to_recv) - } - if at:_bcast_slice_shrd(&a,portion_to_recv) - } - } - } - } - _sync_messages(a,x) -} - -// Resolve x[ indexed ][ priv ] -proc _get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:indexed,complt,at) { - dest_range=_dmap(t,this_tile,#shapex._mshape) - foreach p in nodes_for_grid(shapex.dist,dest_range){ - i=index(dims(local_region.dist),p) - if contains(#(local_region.dist),p) and i/=_this_node() { - other_tile=element(shapex.dist,p) - portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) - _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt) - } - } - src_range=_dunmap(t,shapex._tile,local_region._mshape) - forall j in overlap(this_tile,src_range) { - jj=index(#this_tile,j) - PM__do_at size(this_tile),jj,aa,a,xx,x { - PM__assign(&aa,_getref(xx,null)) - } - } - foreach p in nodes_for_grid(local_region.dist,src_range) { - if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() { - PM__recv_req pp,xx,x,_getref(xx,null) - } - } - if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){ - i=index(dims(local_region.dist),p) - if contains(#(local_region.dist),p) and i/=_this_node() { - other_tile=element(shapex.dist,p) - portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) - _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt) - } - } - _sync_messages(a,x) -} - -// Resolve x[ indexed ][ whatever ] = priv -proc _set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed, pr:invar proc,complt:invar,at:invar) PM__node <>:_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at) -proc _set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed, pr:proc,complt,at) { - t=_correct(tt,shapex._mshape) - dest_range=_dmap(t,this_tile,#shapex._mshape) - PM__head_node{ - foreach p in nodes_for_grid(shapex.dist,dest_range){ - i=index(dims(shapex.dist),p) - if contains(#(shapex.dist),p) and i/=_this_node() { - other_tile=element(shapex.dist,p) - portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) - _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt) - } - } - } - src_range=_dunmap(t,shapex._tile,local_region._mshape) - for j in overlap(this_tile,src_range) { - jj=index(#this_tile,j) - PM__do_at size(this_tile),jj,yy,y,xx,x { - PM__assign(&^(_getlhs(xx,null)),yy,pr) - } - } - foreach p in nodes_for_grid(local_region.dist,src_range) { - i=index(dims(local_region.dist),p) - if contains(#(local_region.dist),p) and i/=_this_node() { - PM__recv_assn pp,xx,yy,x,y,at{ - PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) - } - } - } - _sync_messages(x,y) -} - -// ************************************************************** -// Envelope and stencil definitions -// ************************************************************** -type envelope is rec{cross:extent or null,corner:extent or null,envelope:extent} -proc ortho(x:extent)=new envelope { - cross=x,corner=spread(0..0,x),envelope=x -} -proc ortho(x:extent,y:extent)=new envelope { - cross=if(x inc y=>x,y),corner=y,envelope=envelope(x,y) -} -proc envelope(x:envelope)=x.envelope -proc envelope(x:extent)=x -proc envelope(x:any_int,y:any_int)=min(xx,yy)..max(xx,yy) where xx=int(x),yy=int(y) -proc envelope(x:any_int,y:seq(any_int))=envelope(x..x,y) -proc envelope(x:seq(any_int),y:any_int)=envelope(x,y..y) -proc envelope(x:seq(any_int),y:seq(any_int))=if(size(x)>0=>if(size(y)>0=>min(lx,ly)..max(hx,hy),lx..hx),if(size(y)>0=>0..0,ly..hy)) where lx=min(llx,hhx),ly=min(lly,hhy),hx=max(llx,hhx),hy=max(lly,hhy)where llx=int(low(x)),lly=int(low(y)),hhx=int(high(x)),hhy=int(high(y)) -proc envelope(x:tuple,y:tuple)=map($envelope,x,y) -proc envelope(x:null,y:extent)=y -proc envelope(x:extent,y:null)=x -proc envelope(x:extent or null,y:envelope)=envelope(x,y.envelope) -proc envelope(x:envelope,y:extent or null)=envelope(x.envelope,y) -proc envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope) -proc string(x:envelope)=string(x.cross++" ortho "++x.corner) -// ************************************************************** -// Support for nhd statement -// ************************************************************** -type _nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits} -type nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here} -proc PM__nhd%(x:invar envelope or extent,bound:invar) shrd <>=new _nhd { -_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),_limits=_expand_limits(region._extent,envelope(x),bound)} where t=_get_halo(region,region._tile,envelope(x)) -proc PM__nhd%(x,bound:invar)=^(new _nhd { - _nbhd=n,_tile=t,_tilesz=#t,_interior=t,_limits=region._extent -} -,shrd) where t=region._tile where n=xx where xx=spread(0..0,here){ - _check_nhd%(x) -} -proc _check_nhd%(n:invar envelope or extent) { -} -proc _check_nhd%(n:extent):test "Neighbourhood must be invar"=>fix(false) -proc _check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>fix(false) -proc PM__check_bounds%(b:invar boundary){ - _check_ranks(extent(region),b) -} -proc PM__check_bounds%(b:boundary):test "Bounds must be ""invar"""=>fix(false) -proc PM__check_bounds%(b):test "Bounds must have a boundary type"=>fix(false) -proc _check_ranks(n:tuple,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b)) -proc _check_ranks(n:envelope,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n.cross),rank(b)) -proc _check_ranks(n,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(fix(1),rank(b)) -proc _check_ranks(n,b){ -} -type boundary is boundary_dim,tuple(boundary_dim) -type boundary_dim is CYCLE,EXCLUDED,range(int),null -type CYCLE is unique -type EXCLUDED is unique -proc _expand_limits(t:range(int),n:range(int),b:boundary_dim)=t -proc _expand_limits(t:range(int),n:range(int),b:CYCLE)=_exterior(t,n) -proc _expand_limits(t:tuple,n:tuple,b:boundary_dim)=map($_expand_limits,t,n,spread(b,n)) -proc _expand_limits(t:tuple,n:tuple,b:tuple(boundary_dim))=map($_expand_limits,t,n,b) -proc PM__set_nhd%(&n,x:complete){ - n._array[n._nbhd._interior[n._index]]=x -} -proc PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]=x check "Expression in ""nhd"" must be ""complete"""=>fix(false) -proc PM__nhd_join(x)=x._array -proc PM__nhd_join(x,y)=new _join{ - head=x,tail=y._array -} -proc PM__nhd_var%(x,n:_nhd,i,h)<>=new nbhd{ - _array=_make_nhd%(^(x,shrd),n._tilesz),_nbhd=n,_index=i,_here=h -} -proc PM__nhd_active(region,nbhd,bound:null)=region._extent -proc PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound) -proc PM__nhd_active(region,nbhd,bound){ - r=PM__nhd_active(region,nbhd,spread(bound,region._extent)) - return r -} -proc _nhd_active(r,n,b:CYCLE or null)=r -proc _nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b)) -proc _nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n) -proc _make_nhd%(x:invar,d:invar) shrd <>{ - var v=array(x,d) - return v -} -proc PM__set_edge%(&x,y,z){ -} -proc PM__subref(x:nbhd,t:subs)=_nhd_sub(x,t) -proc PM__subref(x:nbhd,t:null)=_nhd_sub(x,t) -proc _nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))=PM__subref(x._array,tt+x._nbhd._interior[x._index]) { - tt=_tup(t) - test "Subscript"++tt++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),"At "++x._here++" nhd "++tt++" goes outside of boundary "++limits=>contains(limits,dtt) where limits=x._nbhd._limits where dtt=tt+x._here -} - -proc _nhd_sub(x:nbhd,t)=_arb(x._array)check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>fix(false) -proc PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>fix(false) -proc envelope(x:_nhd)=envelope(x._nbhd) -proc envelope(x,y:_nhd)=envelope(x,y._nbhd) -proc envelope(x:_nhd,y:_nhd)=envelope(x._nbhd,y._nbhd) -type _join is struct^{head,tail} -proc PM__blocking%(x:null){ -} -proc PM__blocking%(x):test "Block expression must be tuple of integers"=>fix(false) -proc PM__blocking%(x:tuple(any_int)){ - test "Rank of ""block="" does not match region"=>same_type(rank(x),rank(region)) - test "Block sizes must be positive"=>map_reduce($_positive,$and,x) -} -proc _positive(x)=x>0 -proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shrd <> { - PM__head_node{ - this_tile=region._tile - this_tile_x=nbhd._tile - pp=index2point(_this_node(),dims(region.dist)) - foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { - if contains(#region.dist,i) and i/=pp { - p=index(dims(region.dist),i) - other_tile=element(region.dist,i) - tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) - ov=this_tile_x#intersect(tile_x,other_tile) - if size(ov)>0 { - _recv_slice(p,&a,ov) - } - } - } - foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { - if contains(#region.dist,i) and i/=pp { - p=index(dims(region.dist),i) - other_tile=element(region.dist,i) - other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) - ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) - if size(ov)>0 { - _send_slice(p,a,ov) - } - } - } - _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(false)) - } -} - -proc PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shrd <> { - PM__head_node{ - this_tile=region._tile - this_tile_x=nbhd._tile - pp=index2point(_this_node(),dims(region.dist)) - foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { - if contains(#region.dist,i) and i/=pp { - p=index(dims(region.dist),i) - other_tile=element(region.dist,i) - other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) - ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) - if size(ov)>0 { - _send_slice(p,a,ov) - } - } - } - _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(false)) - } -} - -proc inside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo..lo-y,hi-y..hi)) where lo=low(x),hi=high(x) -proc inside_edge(x:extent,y:tuple(int))=map($inside_edge,x,y) -proc outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y)) where lo=low(x),hi=high(x) -proc outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y) -proc _foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner) -proc _foot(d,n:extent)=n -proc PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shrd <> { - PM__head_node{ - _apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(true)) - } -} - -proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shrd <> { - PM__head_node{ - this_tile=region._tile - this_tile_x=nbhd._tile - pp=index2point(_this_node(),dims(region.dist)) - foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { - if contains(#region.dist,i) and i/=pp { - p=index(dims(region.dist),i) - other_tile=element(region.dist,i) - tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) - ov=this_tile_x#intersect(tile_x,other_tile) - if size(ov)>0 { - _recv_slice_sync(p,&a,ov) - } - } - } - _apply_boundaries(&a,region,envelope(nbhd._nbhd),region._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),fix(true)) - } -} - -proc PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shrd <> { - if shrd_nnode()>1 { - foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 { - chunk=chunk(region,envelope(nbhd._nbhd),i,b) - _bcast_slice_shrd(&a,chunk) - } - } -} - -proc _rev(a:tuple)=map($_rev,a) -proc _rev(a:range)=-high(a)..-low(a) -proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index,recv) { - _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,get_dim(bound,index),index,recv) - _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index-fix(1),recv) -} - -proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index:fix(0),recv) { -} -proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index,recv) { -} -proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:CYCLE,index,recv) { - ex=get_dim(extent,index) - ev=get_dim(envelope,index) - lo=low(ex) - hi=high(ex) - up=max(high(ev),0) - down=min(low(ev),0) - upper_outside=replace(extent,index,hi+1..hi+up) - upper_inside=replace(extent,index,hi+down+1..hi) - lower_outside=replace(extent,index,lo+down..lo-1) - lower_inside=replace(extent,index,lo..lo+up-1) - _copy_bounds(&a,d,n,this_tile_x,upper_outside,lower_inside,recv) - _copy_bounds(&a,d,n,this_tile_x,lower_outside,upper_inside,recv) -} - -proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:fix(false)) { - oldpart,oldtile=overlap(from,d._tile) - newpart,newtile=overlap(to,this_tile_x) - foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { - p=index(dims(d.dist),pp) - if pp in #d.dist and p/=_this_node() { - tile=element(to,overlap(from,element(d.dist,p))) - ov=overlap(this_tile_x,tile) - if size(ov)>0{ - _recv_slice(p,&a,ov) - } - } - } - foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { - p=index(dims(d.dist),pp) - if pp in #d.dist and p/=_this_node() { - tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) - ov=this_tile_x#intersect(d._tile,tile) - if size(ov)>0{ - _send_slice(p,a,ov) - } - } - } -} - -proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:fix(false)) { - oldpart,oldtile=overlap(from,d._tile) - newpart,newtile=overlap(to,this_tile_x) - foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { - p=index(dims(d.dist),pp) - if pp in #d.dist and p/=_this_node() { - tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) - ov=this_tile_x#intersect(d._tile,tile) - if size(ov)>0{ - _send_slice(p,a,ov) - } - } - } -} - -proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:fix(true)) { - oldpart,oldtile=overlap(from,this_tile_x) - newpart,newtile=overlap(to,this_tile_x) - o,oo=overlap(newpart,oldpart) - _set_slice(&a,element(newtile,o),a,element(oldtile,oo)) -} -proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:fix(true)) { - oldpart,oldtile=overlap(from,this_tile_x) - newpart,newtile=overlap(to,this_tile_x) - o,oo=overlap(newpart,oldpart) - _set_slice(&a,element(newtile,o),a, element(oldtile,oo)) - foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { - p=index(dims(d.dist),pp) - if pp in #d.dist and p/=_this_node() { - tile=element(to,overlap(from,element(d.dist,p))) - _recv_slice(p,&a,overlap(this_tile_x,tile)) - } - } -} - -proc _send_slice(p,a:_join,o) { - _send_slice(p,a.head,o) - _send_slice(p,a.tail,o) -} -proc _recv_slice(p,&a:_join,o) { - _recv_slice(p,&a.head,o) - _recv_slice(p,&a.tail,o) -} -proc _recv_slice_sync(p,&a:_join,o){ - _recv_slice_sync(p,&a.head,o) - _recv_slice_sync(p,&a.tail,o) -} -proc _bcast_slice_shrd(&a:_join,o) { - _bcast_slice_shrd(&a.head,o) - _bcast_slice_shrd(&a.tail,o) -} -proc _sync_messages(x:_join):_sync_messages(x.head,x.tail) -proc _not_zero(x)=if(x/=0=>1,0) -proc _crss(x)=1==map_reduce($_not_zero,$+,x) -// Add (anti) halo around tile -// Args: mshape / tile / displacement -// (mshape not used at the moment - there to cope with other topologies) -// Result: expanded tile -proc _get_halo(d:range(int),t:range(int),i:any_int)=low(t)+ii..high(t)+ii where ii=int(i) -proc _get_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)+ii..high(t)+ii by step(t) where ii=int(i) -proc _get_halo(d:range(int),t:block_seq,i:any_int){ - return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i) -} -proc _get_halo(d:range(int),t:map_seq,i:any_int) { - var a=array(0,size(t)) - for j in a,k in t.array:j=k+i - return new map_seq { - array=a - } -} -proc _get_halo(d:range(int),t:range(int),i:range(any_int))=low(t)+int(low(i))..high(t)+int(high(i)) -proc _get_halo(d:range(int),t:strided_range(int),i:range(any_int)){ - var step=step(t) - var width=size(i) - if width>step { - step=1 - width=1 - } - return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) -} -proc _get_halo(d:range(int),t:block_seq,i:range(any_int)){ - var step=step(t) - var width=size(i)+width(t)-1 - if width>step { - step=1 - width=1 - } - return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) -} -proc _get_halo(d:range(int),t:map_seq,i:range(any_int)) { - var a=array(0,[0..size(t)*size(i)-1]) - var m=0 - _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) - return _redim(a,shape(m)) -} -proc _get_halo(d:extent,j:grid,i:tuple(any_int or range(any_int)))= map($_get_halo,d,j,i) -proc _get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_halo(d.1,t.1,i) -proc _get_halo(d,t,i:null)=t -proc _get_anti_halo(d:range(int),t:range(int),i:any_int)=low(t)-ii..high(t)-ii where ii=int(i) -proc _get_anti_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)-ii..high(t)-ii by step(t) where ii=int(i) -proc _get_anti_halo(d:range(int),t:block_seq,i:any_int){ - return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i) -} -proc _get_anti_halo(d:range(int),t:map_seq,i:any_int) { - var a=array(0,size(t)) - for j in a,k in t.array:j=k-i - return new map_seq { - array=a - } -} -proc _get_anti_halo(d:range(int),t:range(int),i:range(any_int))=low(t)-int(high(i))..high(t)-int(low(i)) -proc _get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){ - var step=step(t) - var width=size(i) - if width>step { - step=1 - width=1 - } - return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width) -} -proc _get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){ - var step=step(t) - var width=size(i)+width(t)-1 - if width>step { - step=1 - width=1 - } - return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width) -} -proc _get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) { - var a=array(0,[0..size(t)*size(i)-1]) - var m=0 - _expand_aseq(&m,t.array,size(t.array),&a,-high(i),-low(i)) - return _redim(a,shape(m)) -} -proc _get_anti_halo(d:extent,j:grid, i:tuple(any_int or range(any_int)))= map($_get_anti_halo,d,j,i) -proc _get_anti_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_anti_halo(d.1,t.1,i) -proc _get_anti_halo(d,t,i:null)=t -proc _interior(t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n)) -proc _interior(t:strided_range,n:range)=1..0 by 1 -proc _interior(tt:block_seq,n:range)=block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)where t=middle_blocks(tt) -proc _get_chunk(t:range,n:range,l:fix(true))=low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1) -proc _get_chunk(t:range,n:range,l:fix(false))=low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t) -proc _get_chunk(t:range,n:range,l:_down)=low(t)+w..low(t)+w+w-1 where w=max(0,-low(n)) -proc _get_chunk(t:range,n:range,l:_up)=high(t)-w-w+1..high(t)-w where w=max(0,high(n)) -proc _get_chunk(tt:block_seq,n:range,l:fix(true))=if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t)) where t=middle_blocks(tt) -proc _get_chunk(tt:block_seq,n:range,l:fix(false))=if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t)) where t=middle_blocks(tt) -proc _get_chunk(t:grid_dim,n:range,l:_left or _right)=empty(t) -proc _get_chunk(t:block_seq,n:range,l:_left)=block_seq(low(b),high(b),1,1,0) where b=first_block(t) -proc _get_chunk(t:block_seq,n:range,l:_right)=block_seq(low(b),high(b),1,1,0) where b=last_block(t) -proc _chunk(t,n,r,e,l)=if(r>e=>_interior(t,n),rt,_get_chunk(t,n,l)) -proc _get_chunk(t:tuple1d,n,e,l)=[_chunk(t.1,n.1,1,e,l)] -proc _get_chunk(t:tuple2d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l)] -proc _get_chunk(t:tuple3d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l)] -proc _get_chunk(t:tuple4d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l)] -proc _get_chunk(t:tuple5d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l)] -proc _get_chunk(t:tuple6d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l)] -proc _get_chunk(t:tuple7d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l),_chunk(t.7,n.7,7,e,l)] -proc chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1 -proc chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1 -proc chunks(t:grid,n:extent)=2 -proc _cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n -proc chunk(t:tuple(range(any_int)),n:extent,i:int) { - _cr(i,rank(t)*2) - var r=n - if i==0: r=map($_interior,t,n) elseif i&1==0: r=_get_chunk(t,n,(i+1)/2,fix(true)) else: r=_get_chunk(t,n,(i+1)/2,fix(false)) - return r -} - -type _left is unique -type _right is unique -type _up is unique -type _down is unique -proc chunk(t:tuple(range(any_int) or block_seq),n:extent,i:int) { - _cr(i,rank(t)*4) - var r=t - if i==0:r=map($_interior,t,n) else: switch (i-1)&3 { - case 0:r=_get_chunk(t,n,(i+3)/4,fix(true)) - case 1:r=_get_chunk(t,n,(i+3)/4,fix(false)) - case 2:r=_get_chunk(t,n,(i+3)/4,_left) - default:r=_get_chunk(t,n,(i+3)/4,_right) - } - return r -} -proc chunk(t:grid,n:extent,i:int) { - _cr(i,1) - var r=#t - if i==0:r=empty(#t) - return r -} -proc chunk(t:grid,n:extent,i:int,b:null)=chunk(t,n,i) -proc chunk(t:grid,n:extent,i:int,b:extent)=intersect(chunk(t,n,i),b) -proc inside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix(bool))=_get_chunk(t,n,i,low) -proc outside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix(bool))=_get_chunk(map($_exterior,t,n),n,i,low) -proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:fix(true))=_get_chunk(map($_exterior,t,n),n,i,_up) -proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:fix(false))=_get_chunk(map($_exterior,t,n),n,i,_down) -proc _exterior(t:range(int),n:range(int))=low(t)+min(low(n),0)..high(t)+max(high(n),0) -proc _get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) { - var r=t - tt=map($_exterior,t,n) - if i==0: r=#tt elseif i&1==0: r=_get_chunk(tt,n,(i+1)/2,_up) else: r=_get_chunk(tt,n,(i+1)/2,_down) - return r -} - -// ************************************************************* -// nbr% and nbhd% intrinsics -// ************************************************************* -type disp_index is any_int,tuple(any_int) -type disp_sub is disp_index,tuple(any_int or range(any_int)) -// *** Default *** -proc nbr%(x:chan,t:shrd disp_index,v:shrd){ - test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) - j=displace(region._mshape,here,t) - var y=v - if contains(region._mshape,j) { - y=x![j] - } - return y -} - -proc nbhd%(x:chan,t:shrd disp_sub,v:shrd) { - test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) - var a=array(v,#t) - foreach invar i in t { - j=displace(region._mshape,here,i) - if j in region._mshape { - a[here]=x![j] - } - } - return a -} - -// *** Blocked distributions *** -proc nbr%(region:dshape(,blocked_distr),x:chan,t:shrd disp_index,v:shrd) { - test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) - var j=displace(region._mshape,here,t) - a,ad=tile_with_halo%(x,t,v) - return a[ad#j] -} - -proc nbhd%(region:dshape(,blocked_distr),x:chan,t:shrd disp_sub,v:shrd){ - test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) - a=displace(region._mshape,here,t) - y,yd=tile_with_halo%(x,t,v) - return y[yd#a] -} - -proc tile_with_halo%(x,t,v) { - return a,d where a,d=_local_tile_with_halo(region,PM__local(x),t,v) -} -// Return local tile with halo cells -proc _local_tile_with_halo(region,x,t,v) { - this_tile_x=_get_halo(region._mshape,region._tile,t) - var a=array(v,#this_tile_x) - foreach i in nodes_for_grid(region.dist,this_tile_x) { - other_tile=element(region.dist,i) - other_tile_x=_get_halo(region._mshape,other_tile,t) - var p=index(dims(region.dist),i) - if contains(#region.dist,i) and p/=_this_node() { - _recv_slice(p,&a,overlap(this_tile_x,other_tile)) - } - } - foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { - other_tile=element(region.dist,i) - other_tile_x=_get_halo(region._mshape,other_tile,t) - p=index(dims(region.dist),i) - if contains(#region.dist,i) and p/=_this_node() { - _send_slice(p,x,overlap(region._tile,other_tile_x)) - } - } - o,oo=overlap(this_tile_x,region._tile) - a[o]=x[oo] - _sync_messages(a,x) - return a,this_tile_x -} - -proc _local_tile_with_halo(region,x:_comp,t,v) { - this_tile_x=_get_halo(region._mshape,region._tile,t) - var a=array(v,#this_tile_x) - foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { - other_tile=element(region.dist,i) - other_tile_x=_get_halo(region._mshape,other_tile,t) - p=index(dims(region.dist),i) - if contains(#region.dist,i) and p/=_this_node() { - _send_slice(p,x,overlap(region._tile,other_tile_x)) - } - } - o,oo=overlap(this_tile_x,region._tile) - a[o]=x[oo] - foreach i in nodes_for_grid(region.dist,this_tile_x) { - other_tile=element(region.dist,i) - other_tile_x=_get_halo(region._mshape,other_tile,t) - p=index(dims(region.dist),i) - if contains(dims(region.dist),i) and p/=_this_node() { - _recv_slice_sync(p,&a,overlap(this_tile_x,other_tile)) - } - } - _sync_messages(a,x) - return a,this_tile_x -} - -// Displace x by y within mshape d -proc displace(d:range(int),x:int,y:any_int)=x+int(y) -proc displace(d:range(int),x:int,y:range(any_int))=x+int(y._lo)..x+int(y._hi) -proc displace(d:extent1d,x:tuple1d(int),y:range(any_int) or any_int)=displace(d.1,x.1,y) -proc displace(d:extent,x:tuple(int),y:tuple(range(any_int) or any_int))=map($displace,d,x,y) -// ************************************************ -// TOPOLOGIES -// ************************************************ -proc topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l) -proc topology(tp,dis,d,l:int)=tp -PM__intrinsic<> _get_dims(int,int)->(int) : "get_dims" -PM__intrinsic<> _get_dims(int,int,int)->(int,int) : "get_dims" -PM__intrinsic<> _get_dims(int,int,int,int)->(int,int,int) : "get_dims" -PM__intrinsic<> _get_dims(int,int,int,int,int)->(int,int,int,int) : "get_dims" -PM__intrinsic<> _get_dims(int,int,int,int,int,int)->(int,int,int,int,int) : "get_dims" -PM__intrinsic<> _get_dims(int,int,int,int,int,int,int)->(int,int,int,int,int,int) : "get_dims" -PM__intrinsic<> _get_dims(int,int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "get_dims" -proc _zd(x,y)=if(x==1=>1,nodes_needed(y,x)) -proc cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,spread(VBLOCK,dd),n) -proc cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n) -proc cart_topo(d:tuple1d,t:tuple1d,n:int)=tuple(_get_dims(n,_zd(d.1,t.1))) -proc cart_topo(d:tuple2d,t:tuple2d,n:int)=tuple(b,a) where a,b=_get_dims(n,_zd(d.2,t.2),_zd(d.1,t.1)) -proc cart_topo(d:tuple3d,t:tuple3d,n:int)=tuple(c,b,a) where a,b,c=_get_dims(n,_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) -proc cart_topo(d:tuple4d,t:tuple4d,n:int)=tuple(dd,c,b,a) where a,b,c,dd=_get_dims(n,_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) -proc cart_topo(d:tuple5d,t:tuple5d,n:int)=tuple(e,dd,c,b,a) where a,b,c,dd,e=_get_dims(n,_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) -proc cart_topo(d:tuple6d,t:tuple6d,n:int)=tuple(f,e,dd,c,b,a) where a,b,c,dd,e,f=_get_dims(n,_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) -proc cart_topo(d:tuple7d,t:tuple7d,n:int)=tuple(g,f,e,dd,c,b,a) where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) -// ************************************************ -// DISTRIBUTIONS -// ************************************************ -type distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr -type distr:iterable is null,blocked_distr,distr_dim,tuple(distr_dim),sliced_distr -type blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr) -type distr_template is null,distr_template_dim,tuple(distr_template_dim),... -type distr_template_dim is null,vblock_template,direct_template,block_template,cyclic_template,block_cyclic_template,... -// Null distribution (mirroring) -proc distribute(dis:null,d:int,t:int,p:int)=no_distr(d,t,p) -type no_distr is rec {_hi:int,_p:int,_pr:int} -proc nodes_needed(d:null,g:int)=1 -proc no_distr(g:int,d:int,p:int)=new no_distr { - _hi=int(g),_p=int(d),_pr=p -} -proc #(b:no_distr)=shape([0..b._p-1]) -proc _shp(b:no_distr)=0..b._p-1 -proc dims(b:no_distr)=[b._p] -proc size(b:no_distr)=b._p -proc element(b:no_distr,i:int)=0..b._hi-1 -proc tile_size(b:no_distr,i:int)=b._hi -proc empty(b:no_distr)=1..0 -proc nodes_for_grid(b:no_distr,g:seq(int))=b._pr..b._pr -proc node_for(b:no_distr,j:int)=b._pr -proc index(b:no_distr,j:int,p:int)=j -proc node_nhd(b:no_distr,p:int,d:range(int))=p..p -proc node_co_nhd(b:no_distr,p:int,d:range(int))=p..p -// Direct distribution (1-1 map to processor topology) -type direct_distr is rec {_p:int} -type direct_template is unique{DIRECT} -proc distribute(dis:direct_template,d:int,t:int,p:int)=direct_distr(d) -proc nodes_needed(d:direct_template,g:int)=g -proc direct_distr(d:int)=new direct_distr { - _p=int(d) -} -proc #(b:direct_distr)=shape([0..b._p-1]) -proc _shp(b:direct_distr)=0..b._p-1 -proc dims(b:direct_distr)=[b._p] -proc size(b:direct_distr)=b._p -proc element(b:direct_distr,i:int)=fix(0)..fix(0) -proc tile_size(b:direct_distr,i:int)=fix(1) -proc empty(b:direct_distr)=fix(1)..fix(0) -proc nodes_for_grid(b:direct_distr,g:seq(int))=int(g) -proc node_for(b:direct_distr,j:int)=j -proc index(b:direct_distr,j:int,p:int)=fix(0) -proc node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p -proc node_co_nhd(b:direct_distr,p:int,d:int or range(int))=-low(d)+p..-high(d)+p by -1 -// Variable block distribution -type vblock_distr is rec {_hi:int,_p:int} -type vblock_template is unique{VBLOCK} -proc distribute(dis:vblock_template,d:int,t:int,p:int)=vblock_distr(d,t) -proc nodes_needed(d:vblock_template,g:int)=0 -proc vblock_distr(g:int,d:int)=new vblock_distr { - _hi=int(g),_p=int(d) -} -proc #(b:vblock_distr)=shape([0..b._p-1]) -proc _shp(b:vblock_distr)=0..b._p-1 -proc dims(b:vblock_distr)=[b._p] -proc size(b:vblock_distr)=b._p -proc element(b:vblock_distr,i:int)=start..finish where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) -proc tile_size(b:vblock_distr,i:int)=finish-start+1 where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) -proc empty(b:vblock_distr)=1..0 -proc nodes_for_grid(b:vblock_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(b._p*(low(g)+1)-1,b._hi), hi1=_rdiv(b._p*(high(g)+1)-1,b._hi) -proc node_for(b:vblock_distr,j:int)=p where p=_rdiv(b._p*(j+1)-1,b._hi) -proc index(b:vblock_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._hi/b._p where jj=int(j) -proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) -proc node_nhd(b:vblock_distr,p:int,d:range(int))=p+(low(d)-bk+1)/bk..p+(high(d)+bk-1)/bk where bk=b._hi/b._p -// fixed block distribution -type block_distr is rec {_b:int,_s:int,_p:int} -type _block_template is rec{block:int} -type _block_template_default is unique{BLOCK} -type block_template is _block_template_default,_block_template -proc BLOCK(block:int)=new _block_template { - block=block -} -proc distribute(dis:_block_template,d:int,t:int,p:int)=block_distr(d,t,dis.block) -proc distribute(dis:block_template,d:int,t:int,p:int)=block_distr(d,t) -proc nodes_needed(d:_block_template,g:int)=(g+d.block)/d.block -proc nodes_needed(d:block_template,g:int)=0 -proc block_distr(s:int,p:int)=new block_distr { -_b=b,_s=s,_p=p} where b=(s+p-1)/p -proc block_distr(s:int,t:int,b:int)=new block_distr { -_b=b,_s=s,_p=p} where p=(s+b-1)/b -proc #(b:block_distr)=shape([0..b._p-1]) -proc _shp(b:block_distr)=0..b._p-1 -proc dims(b:block_distr)=[b._p] -proc size(b:block_distr)=b._p -proc element(b:block_distr,i:int)=start..finish where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) -proc tile_size(b:block_distr,i:int)=finish-start+1 where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) -proc empty(b:block_distr)=1..0 -proc nodes_for_grid(b:block_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(int(low(g)),b._b), hi1=_rdiv(int(high(g)),b._b) -proc node_for(b:block_distr,j:int)=p where p=_rdiv(jj,b._b) where jj=int(j) -proc index(b:block_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._b where jj=int(j) -proc node_nhd(b:block_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b -// Cyclic distribution -type cyclic_distr is rec {_hi:int,_p:int} -type cyclic_template is unique{CYCLIC} -proc distribute(dis:cyclic_template,d:int,t:int,p:int)=cyclic_distr(d,t) -proc nodes_needed(d:cyclic_template,g:int)=0 -proc cyclic_distr(g:int,d:int)=new cyclic_distr { - _hi=int(g),_p=int(d) -} -proc #(b:cyclic_distr)=shape([0..b._p-1]) -proc _shp(b:cyclic_distr)=0..b._p-1 -proc dims(b:cyclic_distr)=[b._p] -proc size(b:cyclic_distr)=b._p -proc element(b:cyclic_distr,i:int)= int(i)..b._hi-1 by b._p -proc tile_size(b:cyclic_distr,i:int)=(b._hi-1-int(i))/b._p+1 -proc empty(b:cyclic_distr)=1..0 by 1 -proc nodes_for_grid(b:cyclic_distr,g:seq(int))=cyclic_range(lo,high,p) where high=if(hi-lo>=p=>lo+p-1,hi+if(hi>lo=>0,p)) where lo=low(g) mod p,hi=high(g) mod p where p=b._p -proc node_for(b:cyclic_distr,j:any_int)=p where p=int(j) mod b._p -proc index(b:cyclic_distr,j:int,p:int)=int(j)/b._p -proc node_nhd(b:cyclic_distr,p:int,d:range(int))=cyclic_range(p+low(d),p+high(d),b._p) -// Block cyclic distribution -type block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int} -type block_cyclic_template is rec {block:int} -proc BLOCK_CYCLIC(block:int)=new block_cyclic_template{ - block=block -} -proc distribute(dis:block_cyclic_template,d:int,t:int,p:int)=block_cyclic_distr(d,t,dis.block) -proc nodes_needed(d:block_cyclic_template,g:int)=0 -proc block_cyclic_distr(g:int,p:int,b:int)=new block_cyclic_distr { -_hi=int(g),_p=int(pp),_b=bb, _s=s} where s=pp*bb where bb=if(pp==1=>g,b) where pp=min((g+b-1)/b,p) -proc #(b:block_cyclic_distr)=shape([0..b._p-1]) -proc _shp(b:block_cyclic_distr)=0..b._p-1 -proc dims(b:block_cyclic_distr)=[b._p] -proc size(b:block_cyclic_distr)=b._p -proc element(b:block_cyclic_distr,i:int)= block_seq(s,b._hi-1,b._s,b._b,0) where s=ii*b._b where ii=int(i) -proc tile_size(b:block_cyclic_distr,i:int)=nc*b._b+max(0,min(b._b,df-nc*b._s)) where nc=df/b._s where df=b._hi-s where s=ii*b._b where ii=int(i) -proc empty(b:block_cyclic_distr)=block_seq(1,0,1,1,0) -proc nodes_for_grid(b:block_cyclic_distr,g:grid_dim)=if(hi-lo+1cyclic_range(lo,hi,p),cyclic_range(0,p-1,p)) where lo=low(g)/b._b,hi=high(g)/b._b where p=b._p -proc nodes_for_grid(b:block_cyclic_distr,g:strided_range){ - var r=0..0 - if b._s==step(g) { - r=nodes_for_grid(b,low(g)..low(g))} else { - r=nodes_for_grid(b,low(g)..high(g)) - } - return r -} - -proc nodes_for_grid(b:block_cyclic_distr,g:block_seq){ - var r=cyclic_range(0,0,1) - if b._s==step(g) { - r=nodes_for_grid(b,low(g)..low(g)+width(g)-1)} else { - r=nodes_for_grid(b,low(g)..high(g)) - } - return r -} - -proc node_for(b:block_cyclic_distr,j:int)=p where p=_rdiv(jj,b._b) mod b._p where jj=int(j) -proc index(b:block_cyclic_distr,j:int,p:int)=i where i=r+b._b*(s-p) where r=j-s*b._s where s=_rdiv(j,b._s) -proc node_nhd(b:block_cyclic_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b -proc nodes_for_grid(b,g:single_point)=nodes_for_grid(b,g._t..g._t) -// Tuple of distributions -proc distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))=map($distribute,dis,d,t,p) where p=index2point(_this_node(),t) -proc distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))=map($distribute,spread(dis,d),d,t,p) where p=index2point(_this_node(),t) -proc distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t) -proc nodes_needed(b:tuple(distr_template_dim),g:tuple(int))=map($nodes_needed,b,g) -proc nodes_needed(b:distr_template_dim,g:tuple(int))=map($nodes_needed,spread(b,g),g) -proc node_for(b:tuple(distr_dim),j:tuple(int))=map($node_for,b,j) -proc #(b:tuple(distr_dim))=shape(map($_shp,b)) -proc dims(b:tuple(distr_dim))=map($size,b) -proc element(b:tuple(distr_dim),i:tuple(int))=map($element,b,i) -proc element(b:tuple(distr_dim),i:int)=element(b,index2point(i,dims(b))) -proc tile_size(b:tuple(distr_dim),i:tuple(int))=map($tile_size,b,i) -proc empty(b:tuple(distr_dim))=map($empty,b) -proc nodes_for_grid(b:tuple(distr_dim),g:grid_slice)=map($nodes_for_grid,b,g) -proc node_num_for(b:tuple(distr_dim),j:tuple(int))=index(dims(b),map($node_for,b,j)) -proc index(b:tuple(distr_dim),j:tuple(int),p:tuple(int))=index(tile_size(b,p),map($index,b,j,p)) -proc node_and_index(b:tuple(distr_dim),j:tuple(int))=index(dims(b),p),i where i=index(tile_size(b,p),map($index,b,j,p)) where p=map($node_for,b,j) -proc node_and_index(b:distr_dim,j:int)=p,i where i=index(b,j,p) where p=node_for(b,j) -proc node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d) -proc node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d) -// Slice of a tuple of distributions -type sliced_distr(t,s) is rec{_t:t,_s:s} -proc sliced_distr(t:tuple(distr_dim),s:tuple(seq(int) or single_point(int)))=new sliced_distr{ - _t=t,_s=s -} -proc node_for(t:sliced_distr,j:tuple(int))=node_for(t._t,t._s[j]) -proc #(t:sliced_distr)=#t._t -proc dims(t:sliced_distr)=dims(t._t) -proc element(t:sliced_distr,i:tuple(int) or int)=overlap(t._s,element(t._t,i)) -proc tile_size(t:sliced_distr,i:tuple(int) or int)=dims(element(t,i)) -proc empty(t:sliced_distr)=new sliced_distr{ - _t=empty(t._t),_s=t._s -} -proc nodes_for_grid(t:sliced_distr,g:grid)=nodes_for_grid(t._t,t._s[g]) -proc node_num_for(t:sliced_distr,j:tuple(int))=node_num_for(t._t,t._s[j]) -proc index(t:sliced_distr,j:tuple(int),p:tuple(int))=index(tile_size(t,p),element(t,p)#j) -proc node_and_index(t:sliced_distr,j:int)=p,i where i=index(t,j,p) where p=node_for(t,j) -proc node_nhd(t:sliced_distr,p:tuple,d:tuple)=node_nhd(t._t,p,_stpmult(d,t._s)) -proc node_co_nhd(t:sliced_distr,p:tuple,d:tuple)=node_co_nhd(t._t,p,_stpmult(d,t._s)) -proc _stpmult(d:tuple,s:tuple)=map($_stpmult,d,s) -proc _stpmult(d:range,s:range)=d -proc _stpmult(d:range,s:strided_range)=if(st>0=>st*low(d)..st*high(d),st*high(d)..st*low(d)) where st=step(s) -// ***************************************** -// SUPPORT FOR PARALLEL STATEMENTS -// ***************************************** -// Get and set elements in "for" -proc PM__getelem(x:grid_slice_dim or cyclic_range,y)=element(x,y) -proc PM__getelem(x:grid_slice or iterable_grid,y)=element(x,y) -proc PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t)) -proc PM__getelem(a:array_slice(any^any,),y)=element(a,y) -proc PM__getelem(x:array_template,y)=x._a -proc PM__getelem(a:any^dshape,t)=element(a,(#a)[t]) -proc PM__setelem(&x,v,y) { - _set_elem(&x,v,(#x)[y]) -} -proc PM__setelem(&a:any^mshape,v,t:index){ - PM__setaelem(&a,index(dims(a),t),v) -} - -proc PM__setelem(&a:any^dshape,v,t:index) { - PM__setaelem(&a,i,v) check p==_this_node() where p,i=node_and_index((#a).dist,_tup(t)) -} - -proc PM__setelem(&a:array_slice(any^any,),v,t:index) { - _set_elem(&a._a,v,a._s[t]) -} - -proc PM__get_elem%(x,i,h)=PM__getelem(x,h) -proc PM__set_elem%(&x:invar,v:complete,i,h){ - PM__setelem(&x,v,h <>) - _assemble%(&x,region) -} -proc PM__get_elem%(x:shrd any^dshape,i,h)=element(PM__local(x),i) -proc PM__set_elem%(&x:invar any^dshape,v:complete,i,h) { - _set_elem(&^(PM__local(^(&x))),v,i <>) -} -proc PM__get_elem%(x:shrd array_slice(any^dshape),j,h)=_get_aelem(x._a,i) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) -proc PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){ - PM__setaelem(&x._a,i,v <>) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) -} - -proc _assemble%(&a:invar any^mshape,xregion:invar mshape) { -} -proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) { -} -proc _assemble%(&a:invar any^mshape,xregion:invar) shrd <> { - dist=xregion.dist - foreach p in #(dist) { - tile=dist[p] - i=index(dims(dist),p) - if i==_this_node() { - forall j in tile { - var k=PM__getelem(a,j) - PM__broadcast(&k,i) - } - } else { - forall j in tile { - var k=_arb(a) - PM__broadcast(&k,i) - PM__setelem(&a,k,j <>) - } - } - } -} - -proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar) shrd <> { - dist=xregion.dist - foreach p in #(dist) { - tile=intersect((#(a._a))#a._s,dist[p]) - i=index(dims(dist),p) - if i==_this_node() { - forall j in tile { - var k=PM__getelem(a._a,j) - PM__broadcast(&k,i) - } - } else { - forall j in tile { - var k=_arb(a._a) - PM__broadcast(&k,i) - PM__setelem(&a._a,k,j <>) - } - } - } -} - -// Support for % procs -proc PM__get_tilesz(d)=d._tile,d._size -proc PM__get_tilesz(d:mshape)=d,size(d) -// Support for ! operator -PM__if_compiling -proc PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region)) -proc PM__makearray%(x:priv)=_makearray(x,region,size(region)):test "Can only apply ""!"" to a ""chan"" " => fix(false) -proc PM__makearray%(x:invar)=_makearray(x,region,size(region)):test "Cannot apply ""!"" to a ""shrd"" or ""uniform"" value" => fix(false) -PM__intrinsic<> _makearray(x:any,y:any,z:any)->(PM__invar_dim x,y) : "make_array" -PM__else -proc PM__makearray%(x:chan) complete <>=_makearray(x,region) -proc PM__makearray%(x:priv)=_makearray(x,region):test "Can only apply ""!"" to a ""chan"" " => fix(false) -proc PM__makearray%(x:invar)=_makearray(x,region):test "Cannot apply ""!"" to a ""shrd"" or ""uniform"" value" => fix(false) -PM__intrinsic<> _makearray(x:any,y:any)->(PM__dim x,y) : "make_array" -PM__endif -// active%() intrinsic -proc active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>) -proc _masked%(x) complete <>=masked(x) -proc active%()=^(^??,coherent) -PM__intrinsic PM__active()->(bool) : "active" -// Imports and exports -PM__intrinsic _import_val(x:any)->(=x) : "import_val" -PM__intrinsic PM__importshrd(x:any)->(=x) : "import_val" -PM__intrinsic<> PM__importvarg(x:any)->(=x) : "import_varg" -PM__intrinsic _import_scalar(x:any)->(invar x) : "import_scalar" -proc PM__import_val(x) { - PM__checkimp(x) - return _import_val(x) -} -proc PM__impscalar(x) { - PM__checkimp(x) - return _import_scalar(x) -} -proc PM__import_val(x:PM__anyref(,,,,)) { - test "Compiler internal error:importing reference" => fix(false) - return x -} -proc PM__impscalar(x:PM__anyref(,,,,)) { - test "Compiler internal error:importing reference" => fix(false) - return x -} -proc PM__checkimp(x,...) { - PM__checkimp(x) - PM__checkimp(...) -} -proc PM__checkimp(x) { -} -proc PM__checkimp(x:contains(PM__distr_tag)) { - test "Cannot import a distributed value into a nested parallel scope" => fix(false) -} -type schedule(subregion,blocking) is rec{_subregion:subregion,_subtile,_blocking:blocking} -proc subregion(schedule:schedule)=schedule._subregion -proc subregion(schedule:null)=null -proc subtile(schedule:schedule)=schedule._subtile -// Over statements -proc PM__over%(schedule:null,x:invar,block:invar) shrd <>=new schedule{ - _subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region) -} -proc PM__over%(x:invar,block:invar) shrd <>=new schedule{ -_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(x,schedule._subregion) -proc PM__make_over%(schedule:null,x:invar tuple(subs_dim except stretch_dim),block:invar) shrd <>=new schedule{ -_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s where s=fill_in(region._extent,x,null) -proc PM__make_over%(x:invar tuple(subs_dim except stretch_dim),block:invar) shrd <>=new schedule{ -_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(map($norm,fill_in(region._extent,x,fix(true))),schedule._subregion) -proc PM__make_over%(x:invar,block)=x check "Expression in an ""over"" statement must be a subscript tuple"=>fix(false) -proc PM__make_over%(x,block)=x check "Expression in an ""over"" statement must be ""invar"""=>fix(false) -proc _blocking(b:tuple(any_int),region)=int(b) { - test "Blocking factor must have same rank as current region"=> rank(b)==rank(extent(region)) -} - -proc _blocking(b,region)=null { - test "Blocking factor must be a tuple of integers"=>fix(false) -} -proc _blocking(b:null,region)=null -PM__if_compiling -proc PM__do_over(x:null,region)=x -proc PM__do_over(x:schedule,region)=_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking) -proc _do_elem(x:range(int))=_st(low(x),high(x)) -proc _do_elem(x:strided_range(int))=_st(low(x),high(x),step(x)) -proc _do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x)) -proc _do_elem(x:map_seq)=_st(x.array,size(x.array),null,null) -proc _do_elem(x:single_point)=_st(x._t) -proc PM__nested_loop(x:null){ -} -PM__intrinsic PM__nested_loop(any): "nested_loop" -proc _ldims(x:mshape)=map_apply($size,$_st,x._extent) -proc _ldims(x:dshape)=map_apply($size,$_st,x._tile) -PM__else -proc PM__do_over%(x:null)=true -proc PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion -proc PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile) -proc PM__do_over%(x:invar grid) complete <>{ - chan var t=false - _in%(x,&^(PM__local(^(&t!))) <>) - return t -} - -proc PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x -proc _in%(x:invar,&t:invar) shrd <>{ - forall i in x { - sync t[i]=true - } -} -PM__endif -// Parallel processing inquiry -PM__intrinsic _sys_node()->(int) : "sys_node" -PM__intrinsic sys_nnode()->(int) : "sys_nnode" -PM__intrinsic _this_node()->(int) : "this_node"(1) -PM__intrinsic this_node%(r:any,s:any,h:any)->(int) : "this_node"(2) -PM__intrinsic this_nnode()->(int) : "this_nnode" -PM__intrinsic _shrd_node()->(int) : "shrd_node" -PM__intrinsic shrd_nnode()->(int) : "shrd_nnode" -PM__intrinsic _root_node()->(int) : "root_node" -PM__intrinsic is_shrd()->(bool) : "is_shrd" -PM__intrinsic is_shrd(any)->(bool) : "is_shrd" -PM__intrinsic is_par()->(bool) : "is_par" -proc _head_node()=_shrd_node()==0 -// Parallel system nested contexts -PM__intrinsic<> _push_node_grid(...:any): "push_node_grid" -proc _push_node(d:int,t:int){ - _push_node_grid(false,t) -} -proc _push_node(d:tuple1d,t:tuple1d,e:tuple1d) { - _push_node_grid(is_cyclic(e.1),t.1) -} - -proc _push_node(d:tuple2d,t:tuple2d,e:tuple2d) { - _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),t.1,t.2) -} - -proc _push_node(d:tuple3d,t:tuple3d,e:tuple3d) { - _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),t.1,t.2,t.3) -} - -proc _push_node(d:tuple4d,t:tuple4d,e:tuple4d) { - _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),t.1,t.2,t.3,t.4) -} - -proc _push_node(d:tuple5d,t:tuple5d,e:tuple5d) { - _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),t.1,t.2,t.3,t.4,t.5) -} - -proc _push_node(d:tuple6d,t:tuple6d,e:tuple6d) { - _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),t.1,t.2,t.3,t.4,t.5,t.6) -} - -proc _push_node(d:tuple7d,t:tuple7d,e:tuple7) { - _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),t.1,t.2,t.3,t.4,t.5,t.6,t.7) -} - -PM__intrinsic<> _push_node_split(int): "push_node_split" -PM__intrinsic _push_node_conc(): "push_node_conc" -proc PM__pop_node(x:mshape) { -} -PM__intrinsic PM__pop_node(x:shape): "pop_node" -PM__intrinsic PM__pop_conc(bool): "pop_node_conc" -PM__intrinsic<> _push_node_dist(): "push_node_distr" -proc _lvl()=1 -// ************************************************ -// PROCESSOR ALLOCATION -// ************************************************ -proc PM__partition(pp,d:dshape) { - _push_node_dist() - return dd._tile,dd,null where dd=new dshape { - _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level - } -} -proc PM__partition(pp,d:dshape,distr:null,topo:null,simplify:null,work:null,sched,block) { - _push_node_dist() - return dd._tile,dd,_block_schedule(block,dd) where dd=new dshape { - _mshape=#d._mshape,dist=d.dist, _tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level - } -} - -proc PM__partition(pp,d:dshape,distr,topo,simplify,work,sched,block) { - test "Cannot have attributes in ""for""statement over distributed value" => fix(false) - return dd._tile,dd,null where dd=new dshape { - _mshape=##d,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level - } -} -proc PM__partition(pp,d:mshape)=tile,shape,sched where tile,shape,sched= PM__partition(pp,d,null,null,null,null,null,null) -proc PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) { - d=dims(mshape) - topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode())) - var p=_shrd_node() - dist=distribute(distr,d,topol) - s=size(#(dist)) - np=shrd_nnode() - test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np - if s=s { - p=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) - } - _push_node_split(p) } else { - _push_node_dist() - } - elem=element(dist,p) - elemsz=#elem - dd=new dshape { - _mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz, _size=size(elemsz),_level=_lvl() - } - return dd._tile,dd,_block_schedule(block,dd) -} - -proc PM__partition(pp:null,d:mshape,distr,topo,simplify,work,sched,block)=#d._extent,#d,_block_schedule(block,#d) -proc PM__partition(pp:null,d:dshape,distr,topo,simplify,work,sched,block)=#d._extent,#d._mshape,_block_schedule(block,#d._mshape) -proc _block_schedule(block:null,region)=null -proc _block_schedule(block,region)=new schedule{ - _subregion=region,_subtile=region._tile,_blocking=_blocking(block,region) -} -proc workshare(work:null,d,dist,nnode:int,snode:int,nsnode:int)=nnode*(2*snode+1)/(2*nsnode) -proc workshare(work:array(int),d,dist,nnode:int,snode:int,nsnode:int) { - test "work array does not conform to mshape"=>conform(#work,#d) - var wk=work - return _wshare(wk,nnode,snode,nsnode) -} - -PM__intrinsic _wshare(int^any,int,int,int)->(int) : "wshare" -// ************************************************************* -// I/O OPERATIONS -// ************************************************************* -// Built-in operators -PM__intrinsic<> _open_file(string,bool,bool,bool,bool,bool,bool,bool)->(sint,sint) : "open_file" -PM__intrinsic<> _close_file(sint)->(sint) : "close_file" -PM__intrinsic<> _seek_file(sint,lint)->(sint) : "seek_file" -PM__intrinsic<> _read_file(sint,&any)->(sint) : "read_file" -PM__intrinsic<> _write_file(sint,any)->(sint) : "write_file" -PM__intrinsic<> _read_file_array(sint,&any,int)->(sint) : "read_file_array" -PM__intrinsic<> _write_file_array(sint,any,int)->(sint) : "write_file_array" -PM__intrinsic<> _read_file_tile%(any,any,any,sint,&any,int,int)->(sint) : "read_file_tile" -PM__intrinsic<> _write_file_tile%(any,any,any,sint,any,int,int)->(sint) : "write_file_tile" -PM__intrinsic<> _io_error_string(sint)->(string) : "io_error_string" -// IO/related types -type io_type is num,bool -type filesystem is rec{_tag:PM__distr_tag} -type file is struct {_f:sint,_tag:PM__distr_tag} -type io_error is rec {_errno:sint,use _iserr:bool} -proc PM__filesys()=new filesystem{ -} -// Basic operations - -// @@ with no keys... now, need to pass through keywords - -proc open(&filesystem:filesystem,name,append=false,create=false,temp=false,excl=false,read=false,write=false,seq=false)=new file { - _f=f -},_make_file_error(err) where f,err=_open_file(name,append,create,temp,excl,read,write,seq) -proc _make_file_error(x:sint)=new io_error { - _errno=x,_iserr=x/=0 -} -proc close(&f:file){ - err=_close_file(f._f) - return _make_file_error(err) -} -proc seek(&f:file,j:lint){ - err=_seek_file(f._f,j) - return _make_file_error(err) -} -proc read(&f:file,&x:io_type){ - err=_read_file(f._f,&x) - return _make_file_error(err) -} -proc write(&f:file,x:io_type){ - err=_write_file(f._f,x) - return _make_file_error(err) -} -// Array I/O -proc read(&f:file,&x:io_type^mshape){ - err=_read_file_array(f._f,&x,size(x)) - return _make_file_error(err) -} -proc write(&f:file,x:io_type^mshape){ - err=_write_file_array(f._f,x,size(x)) - return _make_file_error(err) -} -proc read(&f:file,&x:io_type^dshape) { - var err=_make_file_error(0fix(s)) - for i in x:err=read%(&f,&i) - return err -} -proc write(&f:file,x:io_type^dshape) { - var err=_make_file_error(0fix(s)) - for i in x:err=write%(&f,i) -} -// Distributed I/O -proc partition%(f:filesystem)=f:test "Partition not yet implemented"=>fix(false) -proc read%(&f:shrd file,&x:complete io_type){ - err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape)) - return _make_file_error(err) -} -proc write%(&f:shrd file,x:complete io_type){ - err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape)) - return _make_file_error(err) -} -// Error trapping versions of I/O routines -proc string(error:io_error)=_io_error_string(error._errno) -proc open(&f:filesystem,name:string) { - file,error=open(&f,name) - test "Error opening file """++name++""": "++error=>not(error) - return file -} - -proc close(&f:file) { - error=close(&f) - test "Error closing file:"++error=>not(error) -} -proc read(&f:file,&x) { - error=read(&f,&x) - test "Error reading from file:"++error=>not(error) -} -proc write(&f:file,x) { - error=write(&f,x) - test "Error writing to file:"++error=>not(error) -} -proc seek(&f:file,x:lint) { - error=seek(&f,x) - test "Error on seek:"++error=>not(error) -} -proc read%(&f:shrd file,&x) { - error=read%(&f,&x) - test "Error reading from file:"++error=>not(error) -} -proc write%(&f:shrd file,x) { - error=write%(&f,x) - test "Error writing to file:"=>not(error) -} -// ************************************************************* -// SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS -// ************************************************************* -// SOA tuples -type _stuple1d is rec^{t1} -type _stuple2d is rec^{t1,t2} -type _stuple3d is rec^{t1,t2,t3} -type _stuple4d is rec^{t1,t2,t3,t4} -type _stuple5d is rec^{t1,t2,t3,t4,t5} -type _stuple6d is rec^{t1,t2,t3,t4,t5,t6} -type _stuple7d is rec^{t1,t2,t3,t4,t5,t6,t7} -proc _st(t1)=new _stuple1d{ - t1=t1 -} -proc _st(t1,t2)=new _stuple2d{ - t1=t1,t2=t2 -} -proc _st(t1,t2,t3)=new _stuple3d{ - t1=t1,t2=t2,t3=t3 -} -proc _st(t1,t2,t3,t4)=new _stuple4d{ - t1=t1,t2=t2,t3=t3,t4=t4 -} -proc _st(t1,t2,t3,t4,t5)=new _stuple5d{ - t1=t1,t2=t2,t3=t3,t4=t4,t5=t5 -} -proc _st(t1,t2,t3,t4,t5,t6)=new _stuple6d{ - t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 -} -proc _st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{ - t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7 -} -// Create normalised form of a grid used for _xxx_slice operations -proc _norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x)) -proc _norm(n,x:map_seq)=_st(x.array,n) -proc _norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x)) -// Apply idxdim index and convert to normal for for _send_slice_mapped -proc _dnorm(x:indexed_dim(fix(1)),m,n:single_point)=_st(m,t,t,1,1,0) where t=_dmap(x,n._t) -proc _dnorm(x:indexed_dim(fix(1)),m,n:range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),1,1,0) -proc _dnorm(x:indexed_dim(fix(1)),m,n:strided_range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),x._st*n._m,1,0) -proc _dnorm(x:indexed_dim(fix(1),fix(1)),m,n:block_seq)=_st(m,n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) -proc _dnorm(x:indexed_dim(fix(1)),m,n:block_seq)=_dnorm(x,m,map_seq(n)) -proc _dnorm(x:indexed_dim(fix(1)),m,n:map_seq){ - var a=array(0,#n._array) - forall i in a,j in n._array:i=_dmap(x,j) - return _st(a) -} -proc _dnorm(x:indexed_dim(fix(1)),m,n:grid)=_st(map_apply($_dnorm,$_st,x,m,n),size(n)) -type _griddef is rec^{grid,elems} -proc _gd(grid,elems,size)=new _griddef{ - grid=grid,elems=elems -} -proc _send_slice(p,x:_comp^any,d) { - forall i in d { - _isend_offset%(j,p,x) where j=index(#x,i) - } -} - -proc _send_slice(p,x,d) { - _isend_offset(_norm(dims(x),d),p,x) -} - -proc _send_slice_mapped(p,x,d,t,s) { - forall k in d { - _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) - } -} - -proc _send_slice_mapped(p,x:_comp^any,d,t:indexed_dim(fix(1)),s) { - forall k in d { - _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) - } -} - -proc _send_slice_mapped(p,x,d,t:indexed_dim(fix(1)),s) { - _isend_offset(_dnorm(t,dims(x),d),p,x) -} - -proc _recv_slice(p,&x:_comp^any,d) { - forall i in d { - _irecv_offset%(j,p,&x) where j=index(#x,i) - } -} - -proc _recv_slice(p,&x,d) { - _irecv_offset(_norm(dims(x),d),p,&x) -} - -proc _recv_slice_sync(p,&x:_comp^any,d) { - forall i in d { - _recv_offset%(j,p,&x) where j=index(#x,i) - } -} - -proc _recv_slice_sync(p,&x,d) { - _recv_offset(_norm(dims(x),d),p,&x) -} - -proc _bcast_slice_shrd(&x,d){ - _bcast_shrd_offset(_norm(dims(x),d),&x) -} -proc _send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^(fix(true))) { - forall i in d { - j=index(sx,i) - _isend_recv_req%(j,p,^(x),&^(^(a))) - } -} - -proc _send_recv_slice_req(p,x,&a,sx,d,c:^^(fix(true))) { - _isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a))) -} -proc _send_recv_slice_req(p,x,&a,sx,d,c) { - forall i in d { - j=index(sx,i) - _isend_recv_req%(j,p,^(x),&^(^(a)),c) - } -} - -proc _send_slice_assn(p,x:_comp,y,sx,d,c:^^(fix(true))) { - forall i in d { - _isend_assn%(j,^(p),^(x),^(y)) where j=index(sx,i) - } -} - -proc _send_slice_assn(p,x,y,sx,d,c:^^(fix(true))) { - _isend_assn(_norm(dims(sx),d),p,x,y) -} -proc _send_slice_assn(p,x,y,sx,d,c) { - forall i in d { - _isend_assn%(j,p,^(x),^(y),^(c)) where j=index(sx,i) - } -} - -proc _recv_slice_reply(p,&x:_comp,sx,d,c:^^(fix(true))) { - forall i in d { - _recv_reply%(j,^(p),&^(^(x))) where j=index(sx,i) - } -} - -proc _recv_slice_reply(p,&x,sx,d,c:^^(fix(true))) { - _recv_reply(_norm(dims(sx),d),p,&x) -} -proc _recv_slice_reply(p,&x,sx,d,c) { - forall i in d { - _recv_reply%(j,p,&^(^(x)),c) where j=index(sx,i) - } -} - -PM__intrinsic<> _isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any): "isend_offset" -PM__intrinsic<> _isend_offset(j:any,p:any,x:any): "isend_grid" -PM__intrinsic<> _irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "irecv_offset" -PM__intrinsic<> _irecv_offset(j:any,p:any,&x:any): "irecv_grid" -PM__intrinsic<> _recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_offset" -PM__intrinsic<> _recv_offset(j:any,p:any,&x:any): "recv_grid" -PM__intrinsic<> _bcast_shrd_offset%(r:any,s:any,h:any,j:any,&x:any): "bcast_shrd_offset" -PM__intrinsic<> _bcast_shrd_offset(j:any,&x:any): "bcast_shrd_grid" -PM__intrinsic<> _isend(p:any,x:any): "isend" -PM__intrinsic<> _irecv(p:any,&x:any): "irecv" -PM__intrinsic<> _recv(p:any,&x:any): "recv" -PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any): "isend_req" -PM__intrinsic<> _isend_recv_req(j:any,p:any,x:any,&a:any): "isend_req" -PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any): "isend_req" -PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any): "isend_assn" -PM__intrinsic<> _isend_assn(j:any,p:any,x:any,y:any): "isend_assn" -PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any): "isend_assn" -PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any): "recv_reply" -PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_reply" -PM__intrinsic<> _recv_reply(j:any,p:any,&x:any): "recv_reply" -PM__intrinsic<> _bcast_shrd(&x:any): "broadcast_shrd" -PM__intrinsic<> _bcast_shrd(&x:any,p:int): "broadcast_shrd" -type _ct is array_slice,PM__anyref(,,,,),any^any,^^(any) -proc PM__sync_messages(x)<>:_sync_messages(x) -PM__if_compiling -proc _sync_messages(x:_ct):_do_sync_messages(_core(x)) -proc _sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y)) -proc _core(x:any^any)=x -proc _core(x:^^(any))=x -proc _core(x:array_slice)=_core(x._a) -proc _core(x:PM__anyref(,,,,))=_core(_v2(x)) -PM__intrinsic<> _do_sync_messages(...:^^(any) or any^any): "sync_mess" -PM__else -PM__intrinsic<> _sync_messages(...:_ct): "sync_mess" -PM__endif -proc _tup(x:tuple)=x -proc _tup(...)=tuple(...) -proc _tup(x:null)=x -proc _tup%(x:invar) shrd=_tup(x) -PM__intrinsic<> PM__broadcast(&b:any,a:int): "broadcast" -PM__intrinsic<> PM__broadcast(b:any,a:int)->(=b) : "broadcast_val" -PM__intrinsic<> get_remote%(r:any,s:any,h:any,a:shrd any^dshape,b:int,c:int)->(%a) : "get_remote_distr" -PM__intrinsic<> put_remote%(r:any,s:any,h:any,a:shrd any^dshape,b:any,c:int,d:int): "put_remote_distr" -// ******************************************************** -// OTHER COMMUNICATING & ARRAY OPERATIONS -// ******************************************************** -proc map(p:proc,x:any^any) { - var z=array(p.(_arb(x)),#x) - for i in z, j in x:i=p.(j) -} -proc map(p:proc,x:any^any,y:any^any) { - var z=array(p.(_arb(x),_arb(y)),#x) - for i in z,j in x,k in y:i=p.(j,k) -} -proc map(p:proc,x:any^mshape,y:any^dshape) { - var z=array(p.(_arb(x),_arb(y)),#(y)) - for i in z,j in x,k in y:i=p.(j,k) -} -proc map_const(p:proc,x:any^mshape,y:any){ - var z=array(p.(_arb(x),y),#x) - for i in z,j in x:i=p.(j,y) -} -proc +(x:num^any,y:num^any)=map($+,x,y) -proc -(x:num^any,y:num^any)=map($-,x,y) -proc *(x:num^any,y:num^any)=map($*,x,y) -proc /(x:num^any,y:num^any)=map($/,x,y) -proc **(x:num^any,y:num^any)=map($**,x,y) -proc mod(x:real_num^any,y:real_num^any)=map($mod,x,y) -proc max(x:real_num^any,y:real_num^any)=map($max,x,y) -proc min(x:real_num^any,y:real_num^any)=map($min,x,y) -proc +(x:num^any,y:any)=map_const($+,x,y) -proc -(x:num^any,y:any)=map_const($-,x,y) -proc *(x:num^any,y:any)=map_const($*,x,y) -proc /(x:num^any,y:any)=map_const($/,x,y) -proc **(x:num^any,y:any)=map_const($**,x,y) -proc mod(x:real_num^any,y:real_num)=map_const($mod,x,y) -proc max(x:real_num^any,y:real_num)=map_const($max,x,y) -proc min(x:real_num^any,y:real_num)=map_const($min,x,y) -PM__intrinsic _pack(v:any,any,any,d:any)->(PM__dim v,d) : "pack" -proc pack(v:any^mshape,m:bool^mshape) { - test "arrays do not conform"=>conform(#v,#m) - result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) -} - -proc pack(vv:array,mm:array) { - var v=vv - var m=mm - return _pack(v,m,n,tuple(0..n-1)) where n=count(m) -} - -// Reduction -type associative_proc is $+,$*,$max,$min,$&,$|,$~,$++,$==,... -PM__if_compiling -proc reduce(p:proc,x:array(,mshape)) { - var s=_get_aelem(x,0) - foreach i in 1..size(#x)-1 { - s=p.(s,_get_aelem(x,i)) - } - return s -} -PM__else -proc reduce(p:proc,x:array(,mshape)) { - var y=x - var n=size(x) - while n>1 { - var m=(n+1)/2 - forall k in m..n-1 { - PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>) - } - n=m - } - return _get_aelem(y,0) -} - -PM__endif -proc reduce(p:proc,y:array)=_reduce(p,reduce(p,PM__local(y))) -proc _reduce_for_assign%(p:invar associative_proc,y,init:invar){ - chan yy=y - return reduce%(p,yy,init) -} -proc _reduce_for_assign%(p:invar $-,y,init:invar){ - chan yy=y - return init - _reduce%($+,yy,init) -} -proc _reduce_for_assign%(p:invar $/,y,init:invar){ - chan yy=y - return init / _reduce%($*,yy,init) -} -proc reduce%(p:invar proc,y:chan,init)=^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform) -proc _reduce%(p:invar proc,y:chan)=^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform) -proc _reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y) -proc __reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y) -proc _reduce(p:proc,y) { - var x=array(y,[0..0]) - var z=array(y,[0..0]) - var n=this_nnode() - var i=1 - until i>n-1 { - other=_this_node() ~ i - if other=y._lo and x<=y._hi -proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi -proc match_switch_case(x:literal(int),y:_crange)=(x>=y._lo and x<=y._hi) as -proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi -proc match_switch_case(x:,y:)=y inc x -type _crange is rec{_lo,_hi} -proc PM__caserange(x,y)=x..y -proc PM__caserange(x:fix(int),y:fix(int))=new _crange{ - _lo=x,_hi=y -} - -// Conditional operators -proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { - var r=z - if x { - r=y - } - return r -} - -proc PM__if(x:fix(true),y,z)=y -proc PM__if(x:fix(false),y,z)=z -proc PM__if(x:fix(true),y:literal,z)=y -proc PM__if(x:fix(false),y,z:literal)=z -proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { - var r=z - if match(w,x) { - r=y - } - return r -} - -proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) -proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) -proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) -proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) - -// Assignment -proc PM__assign_or_init(a,b)<>=a { - PM__assign_var(&^(a),b) -} - -proc PM__assign_or_init(a:,b)=PM__dup(b as a) - -proc PM__assign_var(&a,b) { - PM__assign(&a,b) -} - -proc PM__assign(&a:any,b:any) { - _assign(&a,c) where c=b as a -} - -type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... - -proc PM__assign(&a:any,b:any,c:assignment_operator) { - PM__assign(&a,c.(a,b)) -} - -proc PM__assign(&a:any,b:any,c:proc) { - test "Not a recognised assignment operator"=>fix(false) -} - -proc check_assign_types(x,y){ - test "Type mismatch in assignment"=>same_type(x,y) -} -proc _assign(&a,b) { - _assign_element(&a,b) -} - -/* -proc _assign(&a:contains(farray),b) { - _assign_structure(&a,b) -} -proc _assign_structure(&a,b)<>{ - _assign_element(&a,b) -} -proc _assign_structure(&a:farray,b){ - _array_assign(&a,b,fix(true)) -} -*/ -PM__intrinsic _assign_element(&any,any): "assign" - - -// Other variable operations -PM__intrinsic PM__clone(x:any)->(=x) : "clone" -//proc PM__dup(PM__dup) <>=PM__clone(PM__dup) -proc PM__dup(PM__dup)=PM__clone(PM__dup) -/* -PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" -PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" -PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" -PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" -PM__intrinsic PM__dup(x:literal(int))->(int) : "clone" -PM__intrinsic PM__dup(x:literal(real))->(real) : "clone" -PM__intrinsic PM__dup(x:literal(string))->(string) : "clone" -PM__intrinsic PM__dup(x:literal(bool))->(bool) : "clone" -*/ -PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" -PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" - -/* -proc ==(x:any,y:any) { - test "Cannot apply ""=="" to different types"=> same_type(x,y) - var ok=true - _eq(x,y,&ok) - return ok -} -proc /=(x:any,y:any) { - test "Cannot apply ""/="" to different types"=> same_type(x,y) - var ok=true - _eq(x,y,&ok) - return not ok -} -proc _eq(x:any,y:any,&ok) <> { - ok=ok and x==y -} -*/ - -PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" -PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" -proc next_enum(x:int)=x+convert(1,x) -proc next_enum(x:int,y:int)=x+convert(y,x) - -PM__intrinsic<> .element_at_index(o:any,r:any,s:any,h:any,m:any,&x:any,y:fix(int))->(|x):"elem" - -proc elements(x)=_elements(x,1) -proc _elements(x,i:literal(int)) { - const e - if fix(i==num_elements(x)) { - e=_cons(PM__element_at(x,i),_list_end) - } else { - e=_cons(PM__element_at(x,i),_elements(x,i+1)) - } - return e -} - -// Type values -PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" -proc is(x,t)=t inc typeof(x) -proc isnt(x,t)=not(x is t) -proc as(x,t:)...=PM__cast(x,t) -proc as(x,t)=PM__cast(x,typeof(t)) -PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" -proc ==(x:,y:)=x inc y and y inc x -PM__intrinsic<> error_type()->(?0) : "call" - -// Debugging -PM__intrinsic<> _dump(any,any): "new_dump" -proc PM__dump(x)<>:_dump("Value:",x) -proc PM__dump(y,x)<>:if y:_dump("Value:",x) -/* -proc PM__dump%(x)<>{ - print("$"++here) - _dump(string(here),x) + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnt(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=PM__cast(x,typeof(t)) +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic<> error_type()->(?0) : "call" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump(x)<>:_dump("Value:",x) +proc PM__dump(y,x)<>:if y:_dump("Value:",x) +/* +proc PM__dump%(x)<>{ + print("$"++here) + _dump(string(here),x) } proc PM__dump%(y:bool,x)<>{ if y:_dump(string(here),x) @@ -5332,3 +1496,17 @@ proc old_dumpit(a) { PM__intrinsic<> old_dump_id(any): "dump_id" proc PM__filesys()=1234 + +proc PM__check_alias(a,b) {} +proc PM__lhs_and_val(a)=a +proc PM__rhs_and_val(a)=a +proc PM__copy_in(a)=a +proc PM__copy_out(&a,b):a=b + +proc PM__for_in(a)=a +proc PM__for_var(a)=a + +proc PM__make_over'(a)=a + +PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_concat" +PM__intrinsic<> PM__list_splice(x:PM__list,y:PM__list,i:literal(int),j:literal(int))->(=x):"list_splice" diff --git a/src/array.f90 b/src/array.f90 index 0942268..36ff734 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -65,7 +65,9 @@ module pm_array contains + !============================================================================= ! Zero any unused (according to ve) elements of vector of long ints + !============================================================================= function vector_zero_unused(context,v,ve,zero) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -100,12 +102,14 @@ function vector_zero_unused(context,v,ve,zero) result(ptr) include 'fvkind.inc' end function vector_zero_unused + !============================================================================= ! Make an array, or vector of arrays ! Defined by four vectors: ! vec - vector of vectors of elements (for all arrays in array vector) ! dom - vector of array domain values ! len - vector of array lengths (num's of elements) ! off - vector giving offset of first element of each array in vec + !============================================================================= function make_array(context,akind,typno,vec,dom,len,off) result(ptr) type(pm_context),pointer:: context integer(pm_p),intent(in):: akind @@ -126,7 +130,9 @@ function make_array(context,akind,typno,vec,dom,len,off) result(ptr) include 'ftypeno.inc' end function make_array - ! LHS value for single array element !!! Needs to use ve + !============================================================================= + ! LHS value for single array element + !============================================================================= function make_elem_ref(context,array,aindex,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: array,aindex,ve @@ -193,7 +199,9 @@ function make_elem_ref(context,array,aindex,ve,errno) result(ptr) include 'fesize.inc' end function make_elem_ref + !============================================================================= ! Dereference an array element LHS reference + !============================================================================= function get_elem_ref(context,p,esize,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: p @@ -219,7 +227,9 @@ function get_elem_ref(context,p,esize,errno) result(ptr) include 'ftypeof.inc' end function get_elem_ref + !============================================================================= ! Get element from reference to struct/rec .n + !============================================================================= function elem_ref_get_struct_elem(context,v,n,esize) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -252,7 +262,9 @@ function elem_ref_get_struct_elem(context,v,n,esize) result(w) include 'fnewnc.inc' end function elem_ref_get_struct_elem + !============================================================================= ! Return domain of an array / reference to array + !============================================================================= function array_dom(context,v,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -289,7 +301,9 @@ function array_dom(context,v,esize) result(ptr) include 'ftypeof.inc' end function array_dom - ! Return size of an array + !============================================================================= + ! Return size of an array or reference to array + !============================================================================= function array_size(context,v,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -325,9 +339,11 @@ function array_size(context,v,esize) result(ptr) include 'ftypeof.inc' end function array_size + !============================================================================= ! Make an array with j elements having intial value val ! domain dom ! (vector inputs yield vector of arrays) + !============================================================================= function make_array_dim(context,typno,val,dom,j,ve) result(ptr) type(pm_context),pointer:: context integer,intent(in):: typno @@ -357,10 +373,12 @@ function make_array_dim(context,typno,val,dom,j,ve) result(ptr) include 'fisnull.inc' include 'fesize.inc' end function make_array_dim - + + !============================================================================= ! Make an array with j elements having intial value val ! domain dom ! (vector inputs yield vector of arrays) + !============================================================================= function make_array_vdim(context,typno,val,dom,j,ve) result(ptr) type(pm_context),pointer:: context integer,intent(in):: typno @@ -389,7 +407,9 @@ function make_array_vdim(context,typno,val,dom,j,ve) result(ptr) include 'fesize.inc' end function make_array_vdim + !============================================================================= ! Create array with same elements (by ref) but new domain + !============================================================================= function array_redim(context,tno,array,dom) result(ptr) type(pm_context),pointer:: context integer,intent(in):: tno @@ -403,7 +423,9 @@ function array_redim(context,tno,array,dom) result(ptr) array%data%ptr(array%offset+pm_array_offset)) end function array_redim + !============================================================================= ! Build array from vector of values + !============================================================================= function make_array_from_vect(context,typno,vec,dom,esize,import_vec) result(ptr) type(pm_context),pointer:: context integer,intent(in):: typno @@ -438,7 +460,9 @@ function make_array_from_vect(context,typno,vec,dom,esize,import_vec) result(ptr include 'fesize.inc' end function make_array_from_vect + !============================================================================= ! Number of elements-1 in vector of arrays + !============================================================================= function array_vector_esize(array) result(size) type(pm_ptr),intent(in):: array integer(pm_ln):: size @@ -447,7 +471,9 @@ function array_vector_esize(array) result(size) include 'fesize.inc' end function array_vector_esize + !============================================================================= ! Size-1 of a vector + !============================================================================= recursive function vector_esize(v) result(esize) type(pm_ptr),intent(in):: v integer(pm_ln):: esize @@ -456,7 +482,7 @@ recursive function vector_esize(v) result(esize) select case(tno) case(pm_array_type,pm_const_array_type) esize=vector_esize(v%data%ptr(v%offset+pm_array_length)) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) esize=vector_esize(v%data%ptr(v%offset+2_pm_p)) case default esize=pm_fast_esize(v) @@ -466,7 +492,9 @@ recursive function vector_esize(v) result(esize) include 'fesize.inc' end function vector_esize + !============================================================================= ! Number of leaves in a vector + !============================================================================= recursive function vector_num_leaves(v) result(n) type(pm_ptr),intent(in):: v integer:: n @@ -475,7 +503,7 @@ recursive function vector_num_leaves(v) result(n) select case(tno) case(pm_array_type,pm_const_array_type) n=vector_num_leaves(v%data%ptr(v%offset+pm_array_vect))+pm_array_size-3 - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) n=0 do i=2,pm_fast_esize(v) n=n+vector_num_leaves(v%data%ptr(v%offset+i)) @@ -487,8 +515,10 @@ recursive function vector_num_leaves(v) result(n) include 'ftypeof.inc' include 'fesize.inc' end function vector_num_leaves - + + !============================================================================= ! Return array element value for given index + !============================================================================= function array_index(context,array,index,ve,esize,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: array,index,ve @@ -556,6 +586,10 @@ function array_index(context,array,index,ve,esize,errno) result(ptr) include 'fisnull.inc' end function array_index + !============================================================================= + ! Return array element value for given index + ! - does the work p=array[idx] with array defined by + !============================================================================= recursive subroutine array_vect_index(context,p,v,idx,offset,esize) type(pm_context),pointer:: context type(pm_ptr),intent(in):: p,v,idx,offset @@ -600,7 +634,7 @@ recursive subroutine array_vect_index(context,p,v,idx,offset,esize) off%data%ln(off%offset+i)=0_pm_ln endif enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_add_root(context,pm_null_obj) do j=2,pm_fast_esize(p) root%ptr=pm_new(context,pm_pointer,esize+1_pm_ln) @@ -727,7 +761,9 @@ recursive subroutine array_vect_index(context,p,v,idx,offset,esize) include 'fesize.inc' end subroutine array_vect_index + !============================================================================= ! Set array element at given index to given value (e) + !============================================================================= subroutine array_set_index(context,array,index,e,ve,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: array,index,e,ve @@ -786,6 +822,10 @@ subroutine array_set_index(context,array,index,e,ve,errno) include 'ftypeof.inc' end subroutine array_set_index + !============================================================================= + ! Set array element + ! - does the work array[idx]=p with array defined by + !============================================================================= recursive subroutine array_vect_set_index(context,v,idx,offset,p,esize,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: p,v,idx,offset @@ -822,7 +862,7 @@ recursive subroutine array_vect_set_index(context,v,idx,offset,p,esize,errno) p,i,errno) endif enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_add_root(context,pm_null_obj) do j=2,pm_fast_esize(p) root%ptr=pm_new(context,pm_pointer,esize+1_pm_ln) @@ -961,6 +1001,9 @@ recursive subroutine array_vect_set_index(context,v,idx,offset,p,esize,errno) include 'fesize.inc' end subroutine array_vect_set_index + !============================================================================= + ! Pack array v + !============================================================================= function array_pack(context,v,t,m,n,d) result(ptr) type(pm_context),pointer:: context integer:: t @@ -989,6 +1032,10 @@ function array_pack(context,v,t,m,n,d) result(ptr) include 'fesize.inc' end function array_pack + !============================================================================= + ! Pack array v using boolean vector m + ! !!! Incomplete + !============================================================================= recursive function vector_pack(context,v,m,n) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,m @@ -1017,7 +1064,7 @@ recursive function vector_pack(context,v,m,n) result(ptr) int(v%data%ptr(v%offset+pm_array_typeof)%offset),& vv,dv,lv,ov) call pm_delete_register(context,reg) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) reg=>pm_register(context,'vpack2',vv) vv=pm_fast_new(context,pm_usr,int(pm_fast_esize(v),pm_p)) vv%data%ptr(vv%offset)=v%data%ptr(v%offset) @@ -1043,6 +1090,7 @@ recursive function vector_pack(context,v,m,n) result(ptr) ptr%data%i(ptr%offset:ptr%offset+esize)=& pack(v%data%i(v%offset:v%offset+esize2),& m%data%l(m%offset:m%offset+esize2)) + end select contains include 'fesize.inc' @@ -1050,6 +1098,9 @@ recursive function vector_pack(context,v,m,n) result(ptr) include 'fnew.inc' end function vector_pack + !============================================================================= + ! Create a new polymorphic vector (ve must be shrunk) + !============================================================================= function poly_new(context,v,ve,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -1076,6 +1127,10 @@ function poly_new(context,v,ve,esize) result(ptr) include 'fnewnc.inc' end function poly_new + + !============================================================================= + ! Assign polymorphic values from w into existing vector v + !============================================================================= subroutine poly_get(context,v,w,ve,esize,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,w,ve @@ -1110,6 +1165,9 @@ subroutine poly_get(context,v,w,ve,esize,errno) include 'fesize.inc' end subroutine poly_get + !============================================================================= + ! Return vector of bool for which polymorphic type is equal to tno + !============================================================================= function poly_check_type(context,v,tno,ve,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -1144,13 +1202,15 @@ function poly_check_type(context,v,tno,ve,esize) result(ptr) include 'fvkind.inc' include 'fesize.inc' end function poly_check_type - + + !============================================================================= ! Import vector using information in import_vec ! import_vec(0) : esize of imported vector ! import_vec(1) : offset into vector being imported ! import_vec(2) : offset into element ! import_vec(3) : total size of imported vector ! import_vec(4:) : size of each segment + !============================================================================= function import_vector(context,v,import_vec) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec @@ -1166,8 +1226,10 @@ function import_vector(context,v,import_vec) result(ptr) contains include 'fesize.inc' end function import_vector - + + !============================================================================= ! Re-export elements of imported vector e back to v + !============================================================================= recursive subroutine export_vector(context,v,e,import_vec) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e,import_vec @@ -1184,7 +1246,7 @@ recursive subroutine export_vector(context,v,e,import_vec) select case(tno) case(pm_array_type,pm_const_array_type) continue - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,n call export_vector(context,& v%data%ptr(v%offset+k),& @@ -1342,7 +1404,10 @@ recursive subroutine export_vector(context,v,e,import_vec) include 'ftypeof.inc' include 'fesize.inc' end subroutine export_vector - + + !============================================================================= + ! Export vector v, creating a new vector + !============================================================================= function export_vector_as_new(context,v,import_vec,ve) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec,ve @@ -1395,8 +1460,10 @@ function export_vector_as_new(context,v,import_vec,ve) result(ptr) include 'ftypeof.inc' end function export_vector_as_new + !============================================================================= ! For any group (defined by import_vec) if any index has a true ! in v then set all that group true in w (else false) + !============================================================================= function vector_if_needed(context,v,import_vec) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec @@ -1438,8 +1505,10 @@ function vector_if_needed(context,v,import_vec) result(w) include 'fesize.inc' end function vector_if_needed + !============================================================================= ! For any group (defined by import_vec) if any index has a true ! in v then next element true in w (else false) + !============================================================================= function vector_export_if_needed(context,v,import_vec) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec @@ -1501,8 +1570,10 @@ function vector_export_if_needed(context,v,import_vec) result(w) include 'fvkind.inc' include 'fesize.inc' end function vector_export_if_needed - + + !============================================================================= ! Build a vector by replicating a scalar value + !============================================================================= recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,j @@ -1562,7 +1633,7 @@ recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(p v%data%ptr(v%offset+pm_elemref_offset),& j,dispv,dispj,siz,full_copy)) call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_new_as_root(context,pm_usr,pm_fast_esize(v)+1_pm_ln) ptr=root%ptr ptr%data%ptr(ptr%offset)=v%data%ptr(v%offset) @@ -1714,8 +1785,10 @@ recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(p include 'fesize.inc' end function make_vector + !============================================================================= ! Make a copy of a vector ! size==-1 means use source size + !============================================================================= recursive function copy_vector(context,v,ve,start,size) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -1803,7 +1876,10 @@ recursive function copy_vector(context,v,ve,start,size) result(ptr) include 'ftypeof.inc' include 'ftiny.inc' end function copy_vector - + + !============================================================================= + ! Copy a distributed reference + !============================================================================= recursive function copy_dref(context,v,size,same_proc,ve) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -1853,7 +1929,10 @@ recursive function copy_dref(context,v,size,same_proc,ve) result(w) contains include 'ftypeof.inc' end function copy_dref - + + !============================================================================= + ! Array assignment of lhs(ix) <- rhs(iy) + !============================================================================= subroutine array_assign(context,lhs,ix,rhs,iy,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: lhs,rhs @@ -1901,8 +1980,10 @@ subroutine array_assign(context,lhs,ix,rhs,iy,errno) include 'fesize.inc' include 'ftypeof.inc' end subroutine array_assign - + + !============================================================================= ! Make an empty copy of a vector with a new length + !============================================================================= recursive function empty_copy_vector(context,v,size) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -1964,7 +2045,9 @@ recursive function empty_copy_vector(context,v,size) result(ptr) include 'ftiny.inc' end function empty_copy_vector + !============================================================================ ! Make a vector by replicating v[offset] + !============================================================================ recursive function vector_from_scalar(context,v,offset,esize,is_const) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -2045,6 +2128,9 @@ recursive function vector_from_scalar(context,v,offset,esize,is_const) result(pt include 'ftiny.inc' end function vector_from_scalar + !============================================================================= + ! Assign lhs <- rhs, masked by ve + !============================================================================= recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) type(pm_context),pointer:: context type(pm_ptr),intent(in):: lhs,rhs,ve @@ -2103,7 +2189,7 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) lhs%data%ptr(lhs%offset+pm_elemref_offset),& rhs,esize,errno) call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do i=2,pm_fast_esize(lhs) call vector_assign(context,& lhs%data%ptr(lhs%offset+i),& @@ -2325,7 +2411,9 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) include 'fvkind.inc' end subroutine vector_assign - ! Test element-by_element equality of two vectors + !============================================================================= + ! Test element-by_element equality of two vectors: eq <- v1 == v2 + !============================================================================= recursive subroutine vector_eq(context,v1,v2,eq,esize,ve) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v1,v2,ve @@ -2403,7 +2491,7 @@ recursive subroutine vector_eq(context,v1,v2,eq,esize,ve) endif enddo endif - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v1) call vector_eq(context,v1%data%ptr(v1%offset+k),& v2%data%ptr(v2%offset+k),eq,esize,ve) @@ -2736,6 +2824,9 @@ recursive subroutine vector_eq(context,v1,v2,eq,esize,ve) include 'fvkind.inc' end subroutine vector_eq + !============================================================================= + ! Check that all(v1(istart:+isize)==v2(istart2:+isize)) + !============================================================================= recursive function vector_all_eq(context,v1,v2,istart1,istart2,isize) result(ok) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v1,v2 @@ -2780,7 +2871,7 @@ recursive function vector_all_eq(context,v1,v2,istart1,istart2,isize) result(ok) vec2%data%ptr(vec2%offset+j),start1,start2,size1) if(.not.ok) return enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v1) if(.not.vector_all_eq(context,v1%data%ptr(v1%offset+k),& v2%data%ptr(v2%offset+k),istart1,istart2,isize)) then @@ -2842,9 +2933,11 @@ recursive function vector_all_eq(context,v1,v2,istart1,istart2,isize) result(ok) include 'fvkind.inc' end function vector_all_eq + !============================================================================= ! Compute a vector of indices ! start, start+step, .., end ! Each index repeated elsize times + !============================================================================= function vector_iota(context,& elsize,start,end,step,import_vec) result(ptr) type(pm_context),pointer:: context @@ -2883,18 +2976,21 @@ function vector_iota(context,& if(idx>iend) idx=istart endif enddo - enddo + enddo + call pm_dump_tree(context,6,vec,2) ptr=vec contains include 'fesize.inc' include 'fisnull.inc' end function vector_iota + !============================================================================= ! Compute a vector of indices ! start, start+step, .., ! Each index repeated elsize times ! The sequence truncated to siz elements ! and truncated to start first elements in + !============================================================================= function vector_iota_trunc(context,& elsize,start,end,step,first,siz,import_vec) result(ptr) type(pm_context),pointer:: context @@ -2948,7 +3044,9 @@ function vector_iota_trunc(context,& include 'fisnull.inc' end function vector_iota_trunc + !============================================================================= ! Calculate indices within block cyclic tile + !============================================================================= subroutine vector_bc(context,ndim,arg,start,end,step,ostart,oend,ostep,& begin,finish,tot,off) type(pm_context),pointer:: context @@ -3204,7 +3302,9 @@ subroutine vector_bc(context,ndim,arg,start,end,step,ostart,oend,ostep,& if(k-off/=tot) call pm_panic('vector_bc') end subroutine vector_bc - + !============================================================================= + ! Produce vector of 1-D indices for a given import vector + !============================================================================= subroutine vector_indices(imp,idx) type(pm_ptr):: imp,idx integer(pm_ln):: i,j,k @@ -3218,8 +3318,10 @@ subroutine vector_indices(imp,idx) contains include 'fesize.inc' end subroutine vector_indices - + + !============================================================================= ! Get elements from a vector (indices start at 0) + !============================================================================= recursive function vector_get_elems(context,v,ix,errno,keeparrays) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ix @@ -3263,7 +3365,7 @@ recursive function vector_get_elems(context,v,ix,errno,keeparrays) result(ptr) int(v%data%ptr(v%offset+pm_array_typeof)%offset),& vec,dom,len,off) call pm_delete_register(context,reg) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_new_as_root(context,pm_usr,pm_fast_esize(v)+1) ptr=root%ptr ptr%data%ptr(ptr%offset)=v%data%ptr(v%offset) @@ -3400,7 +3502,9 @@ recursive function vector_get_elems(context,v,ix,errno,keeparrays) result(ptr) include 'fesize.inc' end function vector_get_elems - ! Set elements in a vector + !============================================================================= + ! Set elements in a vector v[ix]=e masked by ve + !============================================================================= recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ix,e,ve @@ -3437,7 +3541,7 @@ recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) call array_assign(context,v,ix%data%ln(ix%offset+i),e,i,errno) enddo endif - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v) call vector_set_elems(context,v%data%ptr(v%offset+k),& ix,e%data%ptr(e%offset+k),ve,errno) @@ -3677,6 +3781,9 @@ recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) include 'fvkind.inc' end subroutine vector_set_elems + !============================================================================= + ! Assign single element of a vector v[j]=e + !============================================================================= recursive subroutine assign_single(context,v,j,e,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e @@ -3696,7 +3803,7 @@ recursive subroutine assign_single(context,v,j,e,errno) call assign_single(context,v%data%ptr(v%offset+pm_array_dom),j,& e%data%ptr(e%offset+pm_array_dom),errno) call array_assign(context,v,j,e,0_pm_ln,errno) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v) call assign_single(context,v%data%ptr(v%offset+k),j,& e%data%ptr(e%offset+k),errno) @@ -3739,8 +3846,9 @@ recursive subroutine assign_single(context,v,j,e,errno) include 'fesize.inc' end subroutine assign_single - - ! Copy elements of vector e to elements of vector v + !============================================================================= + ! Copy elements of vector e to elements of vector v v(ix) <- e(iy) + !============================================================================= recursive subroutine vector_copy_elems(context,v,e,ix,iy,n,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e @@ -3764,7 +3872,7 @@ recursive subroutine vector_copy_elems(context,v,e,ix,iy,n,errno) call array_assign(context,v,ix(i),e,iy(i),errno) if(errno/=0) return enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v) call vector_copy_elems(context,& v%data%ptr(v%offset+k),& @@ -3882,7 +3990,9 @@ recursive subroutine vector_copy_elems(context,v,e,ix,iy,n,errno) include 'fesize.inc' end subroutine vector_copy_elems + !============================================================================= ! Copy a range of elements from one vector to another + !============================================================================= recursive subroutine vector_copy_range(context,v,start1,e,start2,siz,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e @@ -3893,7 +4003,7 @@ recursive subroutine vector_copy_range(context,v,start1,e,start2,siz,errno) type(pm_ptr):: p k=pm_fast_typeof(v) select case(k) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) if(k/=pm_fast_typeof(e)) then errno=vector_type_error return @@ -3963,6 +4073,9 @@ recursive subroutine vector_copy_range(context,v,start1,e,start2,siz,errno) include 'fesize.inc' end subroutine vector_copy_range + !============================================================================= + ! Dump v to std out with indent of depth + !============================================================================= recursive subroutine vector_dump(context,v,depth) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -4000,25 +4113,28 @@ recursive subroutine vector_dump(context,v,depth) call vector_dump(context,v%data%ptr(v%offset+i),depth+1) enddo write(*,*) spaces(1:depth*2),')' - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) tno=full_type(v) name=pm_type_vect(context,tno) - name=pm_name_val(context,pm_tv_name(name)) - tno=name%data%i(name%offset) - if(k==pm_struct_type) then - write(*,*) spaces(1:depth*2),'struct ',& - trim(pm_name_as_string(context,tno)),'(' + if(pm_tv_kind(name)==pm_type_is_tuple) then + write(*,*) spaces(1:depth*2),'(:' + do i=2,pm_fast_esize(v) + call vector_dump(context,v%data%ptr(v%offset+i),depth+2) + enddo + write(*,*) spaces(1:depth*2),':)' else + name=pm_name_val(context,pm_tv_name(name)) + tno=name%data%i(name%offset) write(*,*) spaces(1:depth*2),'rec ',& trim(pm_name_as_string(context,tno)),'(' + do i=1,pm_fast_esize(name) + tno=name%data%i(name%offset+i) + write(*,*) spaces(1:depth*2+2),& + trim(pm_name_as_string(context,tno)),'=' + call vector_dump(context,v%data%ptr(v%offset+i+1),depth+2) + enddo + write(*,*) spaces(1:depth*2),')' endif - do i=1,pm_fast_esize(name) - tno=name%data%i(name%offset+i) - write(*,*) spaces(1:depth*2+2),& - trim(pm_name_as_string(context,tno)),'=' - call vector_dump(context,v%data%ptr(v%offset+i+1),depth+2) - enddo - write(*,*) spaces(1:depth*2),')' case(pm_name) write(*,*) spaces(1:depth*2),'''',trim(pm_name_as_string(context,int(v%offset))) case(pm_proc) @@ -4036,7 +4152,10 @@ recursive subroutine vector_dump(context,v,depth) include 'fesize.inc' include 'fvkind.inc' end subroutine vector_dump - + + !============================================================================= + ! Dump v using output subroutine output with indent of depth + !============================================================================= recursive subroutine vector_dump_to(context,v,j,output,depth) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -4086,30 +4205,33 @@ end subroutine output call vector_dump_to(context,v%data%ptr(v%offset+i),j,output,depth+1) enddo call output(context,spaces(1:depth*2)//')') - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) tno=full_type(v) name=pm_type_vect(context,tno) - name=pm_name_val(context,pm_tv_name(name)) - tno=name%data%i(name%offset) - if(k==pm_struct_type) then - call output(context,spaces(1:depth*2)//'struct '//& - trim(pm_name_as_string(context,tno))//'(') + if(pm_tv_kind(name)==pm_type_is_tuple) then + call output(context,spaces(1:depth*2)//'(:') + do i=2,pm_fast_esize(v) + call vector_dump_to(context,v%data%ptr(v%offset+i),j,output,depth+2) + enddo + call output(context,spaces(1:depth*2)//':)') else + name=pm_name_val(context,pm_tv_name(name)) + tno=name%data%i(name%offset) call output(context,spaces(1:depth*2)//'rec '//& trim(pm_name_as_string(context,tno))//'(') + do i=1,pm_fast_esize(name) + name1=name%data%i(name%offset+i) + if(abs(name1)>=sym_d1.and.abs(name1)<=sym_d7) then + call output(context,spaces(1:depth*2+2)//& + achar(iachar('1')+name1-sym_d1)//'=') + else + call output(context,spaces(1:depth*2+2)//& + trim(pm_name_as_string(context,name1))//'=') + endif + call vector_dump_to(context,v%data%ptr(v%offset+i+1),j,output,depth+2) + enddo + call output(context,spaces(1:depth*2)//')') endif - do i=1,pm_fast_esize(name) - name1=name%data%i(name%offset+i) - if(abs(name1)>=sym_d1.and.abs(name1)<=sym_d7) then - call output(context,spaces(1:depth*2+2)//& - achar(iachar('1')+name1-sym_d1)//'=') - else - call output(context,spaces(1:depth*2+2)//& - trim(pm_name_as_string(context,name1))//'=') - endif - call vector_dump_to(context,v%data%ptr(v%offset+i+1),j,output,depth+2) - enddo - call output(context,spaces(1:depth*2)//')') case(pm_name) call output(context,spaces(1:depth*2)//trim(pm_name_as_string(context,int(v%offset)))) case(pm_null) @@ -4135,8 +4257,9 @@ end subroutine output include 'fvkind.inc' end subroutine vector_dump_to - + !============================================================================= ! Calculate total array vector size from array lengths vector + !============================================================================= function total_size(v) result(siz) type(pm_ptr),intent(in):: v integer(pm_ln):: siz @@ -4145,7 +4268,9 @@ function total_size(v) result(siz) include 'fesize.inc' end function total_size + !============================================================================= ! Check that two vectors of longs are identical + !============================================================================= function all_equal(len,len2) result(ok) type(pm_ptr),intent(in):: len,len2 logical:: ok @@ -4157,8 +4282,10 @@ function all_equal(len,len2) result(ok) include 'fesize.inc' end function all_equal + !============================================================================= ! Calculate array offsets vector for contiguous elements ! from array length vector + !============================================================================= function array_offsets(context,len) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len @@ -4169,8 +4296,10 @@ function array_offsets(context,len) result(ptr) include 'fesize.inc' end function array_offsets + !============================================================================= ! Calculate array offsets vector for contiguous elements ! from array length vector (set pre-allocated vector) + !============================================================================= subroutine set_offsets(off,len) type(pm_ptr):: len,off integer(pm_ln):: i,s @@ -4183,9 +4312,11 @@ subroutine set_offsets(off,len) include 'fesize.inc' end subroutine set_offsets + !============================================================================= ! For vector of arrays (defined by len(gth) and off(set) vectors) ! and vector of indices, compute vector of locations in array ! element vector + !============================================================================= function index_vector(context,len,off,idx,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,ve @@ -4209,9 +4340,11 @@ function index_vector(context,len,off,idx,ve,errno) result(ptr) include 'fesize.inc' end function index_vector + !============================================================================= ! For vector of arrays (defined by len(gth) and off(set) vectors) ! and vector of indices, combined with indirection vector, ! compute vector of locations in array element vector + !============================================================================= function index_vector_indirect(context,len,off,idx,ind,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,ind,ve @@ -4237,9 +4370,11 @@ function index_vector_indirect(context,len,off,idx,ind,ve,errno) result(ptr) include 'ftypeof.inc' end function index_vector_indirect + !============================================================================= ! For vector of arrays (defined by len(gth) and off(set) vectors) ! and vector of indices, compute vector of locations in array ! element vector, excluding inactive locations (as defined by ve) + !============================================================================= function index_vector_used(context,len,off,idx,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,ve @@ -4302,7 +4437,9 @@ function index_vector_used(context,len,off,idx,ve,errno) result(ptr) include 'fvkind.inc' end function index_vector_used + !============================================================================= ! Compute indices for all elements in an array + !============================================================================= function index_vector_all(context,len,off) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off @@ -4324,8 +4461,10 @@ function index_vector_all(context,len,off) result(ptr) include 'fesize.inc' end function index_vector_all + !============================================================================= ! For vector of arrays defined by (len,off) and vector of arrays of indices - ! defined by (len2[disp...],idx), calculate vector of array element locations + ! defined by (len2[disp...],idx), calculate vector of array element locations + !============================================================================= function index_vector_nested(context,len,off,idx,import_vec,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,import_vec @@ -4364,6 +4503,9 @@ function index_vector_nested(context,len,off,idx,import_vec,errno) result(ptr) include 'fesize.inc' end function index_vector_nested + !============================================================================= + ! Apply fmt to each element of v to create vector of strings + !============================================================================= function vector_make_string(context,ve,v,buf_size,fmt) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: ve,v @@ -4403,6 +4545,10 @@ end subroutine fmt include 'fesize.inc' end function vector_make_string + !================================================================================= + ! Concatenate strings in each element of v1 and v2: str <- v1 ++ v2 masked by ve + ! -- ve must be shrunk + !================================================================================== function vector_concat_string(context,ve,v1,v2) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: ve,v1,v2 @@ -4448,6 +4594,9 @@ function vector_concat_string(context,ve,v1,v2) result(str) include 'fesize.inc' end function vector_concat_string + !============================================================================= + ! Get string for v[ve[i] where ve must be shrunk + !============================================================================= subroutine vector_get_string(context,v,ve,i,str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -4472,7 +4621,10 @@ subroutine vector_get_string(context,v,ve,i,str) contains include 'fesize.inc' end subroutine vector_get_string - + + !============================================================================= + ! Make a vector of unitialised strings + !============================================================================= function make_string_vector(context,val,esize) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val @@ -4498,6 +4650,7 @@ function make_string_vector(context,val,esize) result(str) include 'fesize.inc' end function make_string_vector + ! Integer format subroutine fmt_i(v,n,str) type(pm_ptr),intent(in):: v integer(pm_ln),intent(in):: n @@ -4508,6 +4661,7 @@ subroutine fmt_i(v,n,str) str=adjustl(mess) end subroutine fmt_i + ! Long integer format subroutine fmt_ln(v,n,str) type(pm_ptr),intent(in):: v integer(pm_ln),intent(in):: n @@ -4518,6 +4672,7 @@ subroutine fmt_ln(v,n,str) str=adjustl(mess) end subroutine fmt_ln + subroutine fmt_lln(v,n,str) type(pm_ptr),intent(in):: v integer(pm_ln),intent(in):: n @@ -4580,271 +4735,278 @@ subroutine fmt_l(v,n,str) end subroutine fmt_l - subroutine advance_dim(val,max,overflow,n) - integer(pm_ln),dimension(*),intent(inout):: val,max - integer(pm_ln),dimension(*),intent(inout):: overflow - integer(pm_ln),intent(in):: n - integer(pm_ln):: i - do i=1,n - val(i)=val(i)+overflow(i) - enddo - do i=1,n - overflow(i)=merge(1_pm_ln,0_pm_ln,val(i)>=max(i)) - val(i)=merge(0_pm_ln,val(i),val(i)>=max(i)) - enddo - end subroutine advance_dim - - function advance(context,val,max,ok) result(mask) - type(pm_context),pointer:: context - type(pm_ptr),intent(inout):: val - type(pm_ptr),intent(in)::max - type(pm_ptr),intent(in),optional:: ok - type(pm_ptr):: mask - integer(pm_ln),allocatable,dimension(:):: overflow - integer(pm_ln):: i,esize - integer:: j - type(pm_ptr):: v,m - esize=pm_fast_esize(val%data%ptr(val%offset+2)) - allocate(overflow(0:esize)) - overflow=1 - do j=2,pm_fast_esize(val) - v=val%data%ptr(val%offset+j) - m=max%data%ptr(max%offset+j) - call advance_dim(v%data%ln(v%offset:),m%data%ln(m%offset:),overflow,esize+1) - enddo - mask=pm_new(context,pm_logical,esize+1) - if(present(ok)) then - do i=0,esize - mask%data%l(mask%offset+i)=overflow(i)==0.and.ok%data%l(ok%offset+i) - enddo - else - do i=0,esize - mask%data%l(mask%offset+i)=overflow(i)==0 - enddo - endif - deallocate(overflow) - contains - include 'fesize.inc' - end function advance - - function init_loop(context,v) result(w) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: v - type(pm_ptr):: w - integer(pm_ln):: esize,n,i - type(pm_ptr):: p - type(pm_root),pointer:: root - esize=pm_fast_esize(v%data%ptr(v%offset+2)) - n=pm_fast_esize(v) - root=>pm_new_as_root(context,pm_usr,n) - w=root%ptr - w%data%ptr(w%offset)=v%data%ptr(v%offset) - w%data%ptr(w%offset+1)=v%data%ptr(v%offset+1) - do i=2,n - p=pm_assign_new(context,w,i,pm_long,esize+1,.false.) - p%data%ln(p%offset:p%offset+esize)=0 - enddo - call pm_delete_root(context,root) - contains - include 'fesize.inc' - end function init_loop +!!$ subroutine advance_dim(val,max,overflow,n) +!!$ integer(pm_ln),dimension(*),intent(inout):: val,max +!!$ integer(pm_ln),dimension(*),intent(inout):: overflow +!!$ integer(pm_ln),intent(in):: n +!!$ integer(pm_ln):: i +!!$ do i=1,n +!!$ val(i)=val(i)+overflow(i) +!!$ enddo +!!$ do i=1,n +!!$ overflow(i)=merge(1_pm_ln,0_pm_ln,val(i)>=max(i)) +!!$ val(i)=merge(0_pm_ln,val(i),val(i)>=max(i)) +!!$ enddo +!!$ end subroutine advance_dim +!!$ +!!$ function advance(context,val,max,ok) result(mask) +!!$ type(pm_context),pointer:: context +!!$ type(pm_ptr),intent(inout):: val +!!$ type(pm_ptr),intent(in)::max +!!$ type(pm_ptr),intent(in),optional:: ok +!!$ type(pm_ptr):: mask +!!$ integer(pm_ln),allocatable,dimension(:):: overflow +!!$ integer(pm_ln):: i,esize +!!$ integer:: j +!!$ type(pm_ptr):: v,m +!!$ esize=pm_fast_esize(val%data%ptr(val%offset+2)) +!!$ allocate(overflow(0:esize)) +!!$ overflow=1 +!!$ do j=2,pm_fast_esize(val) +!!$ v=val%data%ptr(val%offset+j) +!!$ m=max%data%ptr(max%offset+j) +!!$ call advance_dim(v%data%ln(v%offset:),m%data%ln(m%offset:),overflow,esize+1) +!!$ enddo +!!$ mask=pm_new(context,pm_logical,esize+1) +!!$ if(present(ok)) then +!!$ do i=0,esize +!!$ mask%data%l(mask%offset+i)=overflow(i)==0.and.ok%data%l(ok%offset+i) +!!$ enddo +!!$ else +!!$ do i=0,esize +!!$ mask%data%l(mask%offset+i)=overflow(i)==0 +!!$ enddo +!!$ endif +!!$ deallocate(overflow) +!!$ contains +!!$ include 'fesize.inc' +!!$ end function advance +!!$ +!!$ function init_loop(context,v) result(w) +!!$ type(pm_context),pointer:: context +!!$ type(pm_ptr),intent(in):: v +!!$ type(pm_ptr):: w +!!$ integer(pm_ln):: esize,n,i +!!$ type(pm_ptr):: p +!!$ type(pm_root),pointer:: root +!!$ esize=pm_fast_esize(v%data%ptr(v%offset+2)) +!!$ n=pm_fast_esize(v) +!!$ root=>pm_new_as_root(context,pm_usr,n) +!!$ w=root%ptr +!!$ w%data%ptr(w%offset)=v%data%ptr(v%offset) +!!$ w%data%ptr(w%offset+1)=v%data%ptr(v%offset+1) +!!$ do i=2,n +!!$ p=pm_assign_new(context,w,i,pm_long,esize+1,.false.) +!!$ p%data%ln(p%offset:p%offset+esize)=0 +!!$ enddo +!!$ call pm_delete_root(context,root) +!!$ contains +!!$ include 'fesize.inc' +!!$ end function init_loop - recursive function ptr_vec_get_type(context,& - vec,disps,start,finish) result(outvec) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: vec,disps - integer(pm_ln):: start,finish - type(pm_ptr):: outvec - integer(pm_ln):: esize,j,k,n - integer:: vkind - type(pm_ptr):: p,pvec - type(pm_root),pointer:: root1,root2 - p=vec%data%ptr(vec%offset) - vkind=pm_fast_vkind(p) - esize=finish-start - select case(vkind) - case(pm_int) - outvec=pm_new(context,pm_int,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i(outvec%offset+j)=& - p%data%i(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_long) - outvec=pm_new(context,pm_long,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%ln(outvec%offset+j)=& - p%data%ln(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int8) - outvec=pm_new(context,pm_int8,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i8(outvec%offset+j)=& - p%data%i8(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int16) - outvec=pm_new(context,pm_int16,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i16(outvec%offset+j)=& - p%data%i16(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int32) - outvec=pm_new(context,pm_int32,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i32(outvec%offset+j)=& - p%data%i32(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int64) - outvec=pm_new(context,pm_int64,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i64(outvec%offset+j)=& - p%data%i64(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int128) - outvec=pm_new(context,pm_int128,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i128(outvec%offset+j)=& - p%data%i128(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_single) - outvec=pm_new(context,pm_single,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r(outvec%offset+j)=& - p%data%r(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_double) - outvec=pm_new(context,pm_double,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%d(outvec%offset+j)=& - p%data%d(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_real32) - outvec=pm_new(context,pm_real32,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r32(outvec%offset+j)=& - p%data%r32(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_real64) - outvec=pm_new(context,pm_real64,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r64(outvec%offset+j)=& - p%data%r64(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_real128) - outvec=pm_new(context,pm_real128,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r128(outvec%offset+j)=& - p%data%r128(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_single_complex) - outvec=pm_new(context,pm_single_complex,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c(outvec%offset+j)=& - p%data%c(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_double_complex) - outvec=pm_new(context,pm_double_complex,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%dc(outvec%offset+j)=& - p%data%dc(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_complex64) - outvec=pm_new(context,pm_complex64,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c64(outvec%offset+j)=& - p%data%c64(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_complex128) - outvec=pm_new(context,pm_complex128,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c128(outvec%offset+j)=& - p%data%c128(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_complex256) - outvec=pm_new(context,pm_complex256,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c256(outvec%offset+j)=& - p%data%c256(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_logical) - outvec=pm_new(context,pm_logical,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%l(outvec%offset+j)=& - p%data%l(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_packed_logical) - outvec=pm_new(context,pm_packed_logical,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%pl(outvec%offset+j)=& - p%data%pl(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_undef:pm_null,pm_pointer:pm_stack) - outvec=pm_new(context,pm_pointer,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%ptr(outvec%offset+j)=& - p%data%ptr(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_usr) - n=pm_fast_esize(vec%data%ptr(vec%offset)) - root1=>pm_new_as_root(context,pm_pointer,n) - root2=>pm_new_as_root(context,pm_pointer,esize) - outvec=root1%ptr - pvec=root2%ptr - do j=1,n - do k=0,esize - p=vec%data%ptr(vec%offset+k+start) - pvec%data%ptr(pvec%offset+k)=p%data%ptr(p%offset+j) - enddo - call pm_ptr_assign(context,outvec,j,& - ptr_vec_get_type(context,pvec,disps,0_pm_ln,esize)) - enddo - call pm_delete_root(context,root1) - call pm_delete_root(context,root2) - end select - contains - include 'fvkind.inc' - include 'fesize.inc' - end function ptr_vec_get_type +!!$ recursive function ptr_vec_get_type(context,& +!!$ vec,disps,start,finish) result(outvec) +!!$ type(pm_context),pointer:: context +!!$ type(pm_ptr),intent(in):: vec,disps +!!$ integer(pm_ln):: start,finish +!!$ type(pm_ptr):: outvec +!!$ integer(pm_ln):: esize,j,k,n +!!$ integer:: vkind +!!$ type(pm_ptr):: p,pvec +!!$ type(pm_root),pointer:: root1,root2 +!!$ p=vec%data%ptr(vec%offset) +!!$ vkind=pm_fast_vkind(p) +!!$ esize=finish-start +!!$ select case(vkind) +!!$ case(pm_int) +!!$ outvec=pm_new(context,pm_int,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i(outvec%offset+j)=& +!!$ p%data%i(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_long) +!!$ outvec=pm_new(context,pm_long,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%ln(outvec%offset+j)=& +!!$ p%data%ln(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int8) +!!$ outvec=pm_new(context,pm_int8,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i8(outvec%offset+j)=& +!!$ p%data%i8(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int16) +!!$ outvec=pm_new(context,pm_int16,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i16(outvec%offset+j)=& +!!$ p%data%i16(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int32) +!!$ outvec=pm_new(context,pm_int32,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i32(outvec%offset+j)=& +!!$ p%data%i32(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int64) +!!$ outvec=pm_new(context,pm_int64,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i64(outvec%offset+j)=& +!!$ p%data%i64(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int128) +!!$ outvec=pm_new(context,pm_int128,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i128(outvec%offset+j)=& +!!$ p%data%i128(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_single) +!!$ outvec=pm_new(context,pm_single,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r(outvec%offset+j)=& +!!$ p%data%r(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_double) +!!$ outvec=pm_new(context,pm_double,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%d(outvec%offset+j)=& +!!$ p%data%d(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_real32) +!!$ outvec=pm_new(context,pm_real32,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r32(outvec%offset+j)=& +!!$ p%data%r32(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_real64) +!!$ outvec=pm_new(context,pm_real64,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r64(outvec%offset+j)=& +!!$ p%data%r64(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_real128) +!!$ outvec=pm_new(context,pm_real128,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r128(outvec%offset+j)=& +!!$ p%data%r128(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_single_complex) +!!$ outvec=pm_new(context,pm_single_complex,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c(outvec%offset+j)=& +!!$ p%data%c(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_double_complex) +!!$ outvec=pm_new(context,pm_double_complex,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%dc(outvec%offset+j)=& +!!$ p%data%dc(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_complex64) +!!$ outvec=pm_new(context,pm_complex64,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c64(outvec%offset+j)=& +!!$ p%data%c64(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_complex128) +!!$ outvec=pm_new(context,pm_complex128,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c128(outvec%offset+j)=& +!!$ p%data%c128(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_complex256) +!!$ outvec=pm_new(context,pm_complex256,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c256(outvec%offset+j)=& +!!$ p%data%c256(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_logical) +!!$ outvec=pm_new(context,pm_logical,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%l(outvec%offset+j)=& +!!$ p%data%l(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_packed_logical) +!!$ outvec=pm_new(context,pm_packed_logical,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%pl(outvec%offset+j)=& +!!$ p%data%pl(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_undef:pm_null,pm_pointer:pm_stack) +!!$ outvec=pm_new(context,pm_pointer,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%ptr(outvec%offset+j)=& +!!$ p%data%ptr(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_usr) +!!$ n=pm_fast_esize(vec%data%ptr(vec%offset)) +!!$ root1=>pm_new_as_root(context,pm_pointer,n) +!!$ root2=>pm_new_as_root(context,pm_pointer,esize) +!!$ outvec=root1%ptr +!!$ pvec=root2%ptr +!!$ do j=1,n +!!$ do k=0,esize +!!$ p=vec%data%ptr(vec%offset+k+start) +!!$ pvec%data%ptr(pvec%offset+k)=p%data%ptr(p%offset+j) +!!$ enddo +!!$ call pm_ptr_assign(context,outvec,j,& +!!$ ptr_vec_get_type(context,pvec,disps,0_pm_ln,esize)) +!!$ enddo +!!$ call pm_delete_root(context,root1) +!!$ call pm_delete_root(context,root2) +!!$ end select +!!$ contains +!!$ include 'fvkind.inc' +!!$ include 'fesize.inc' +!!$ end function ptr_vec_get_type + + !============================================================================= + ! Shrink a ve to the list-of-indices form + ! - Convert logical mask to vector of active indices + ! - Convert null make to vecror of consecutive indices + ! - Leave a list of indices alone + !============================================================================= function shrink_ve(context,mask,esize,n) result(ind) type(pm_context),pointer:: context type(pm_ptr),intent(in):: mask @@ -4884,18 +5046,25 @@ function shrink_ve(context,mask,esize,n) result(ind) include 'fisnull.inc' include 'ftiny.inc' end function shrink_ve - + + !============================================================================= + ! Return the type of an interpreter object + !============================================================================= function full_type(v) result(tno) type(pm_ptr):: v integer:: tno tno=pm_fast_typeof(v) - if(tno>=pm_struct_type) then + if(tno>=pm_rec_type) then tno=v%data%ptr(v%offset+1_pm_p)%offset endif contains include 'ftypeof.inc' end function full_type + !============================================================================= + ! Compute intersection of two monotonic sequences a1(1:n1) and a2(1:n1) + ! with result stored in a3(1:n3) -- a3 must have enough space + !============================================================================= subroutine intersect_aseq(a1,n1,a2,n2,a3,n3) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -4985,6 +5154,9 @@ subroutine intersect_aseq(a1,n1,a2,n2,a3,n3) endif end subroutine intersect_aseq + !============================================================================= + ! Check if monotonic sequenc a1(1:n1) includes monotonic sequence a2(1:n2) + !============================================================================= function aseq_includes(a1,n1,a2,n2) result(ok) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -5057,6 +5229,9 @@ function aseq_includes(a1,n1,a2,n2) result(ok) endif end function aseq_includes + !============================================================================= + ! Find index of v in monotonic sequence a(1:n) + !============================================================================= function aseq_index(a,n,v) result(index) integer(pm_ln),dimension(*),intent(in):: a integer(pm_ln),intent(in):: n @@ -5095,6 +5270,10 @@ function aseq_index(a,n,v) result(index) endif end function aseq_index + !================================================================================ + ! a3(1:n3) is set to a vector of indices of elements of monotonic sequence + ! a2(1:n2) in monotic sequnce a1(1:n1), excluding elements of a2 not found in a1 + !================================================================================ subroutine overlap_aseq(a1,n1,a2,n2,a3,n3) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -5184,6 +5363,10 @@ subroutine overlap_aseq(a1,n1,a2,n2,a3,n3) endif end subroutine overlap_aseq + !============================================================================= + ! Set a3 to overlap of a1 and a2 and a4 to overlap of a2 and a1 + ! where overlap is as defined for overlap_aseq + !============================================================================= subroutine overlap_aseq2(a1,n1,a2,n2,a3,a4,n3) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -5276,7 +5459,12 @@ subroutine overlap_aseq2(a1,n1,a2,n2,a3,a4,n3) endif endif end subroutine overlap_aseq2 - + + !============================================================================= + ! Intersect two blocked sequences (l1..h1 by st1 width wd1) and + ! (l2..h3 by st2 width wd2) giving sequence a(1:n) + ! - array a must have enough space + !============================================================================= subroutine intersect_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) integer(pm_ln),intent(in):: l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2 integer(pm_ln),dimension(*),intent(out):: a @@ -5373,6 +5561,13 @@ subroutine intersect_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) n=k-1 end subroutine intersect_bseq + + !============================================================================= + ! Overlap two blocked sequences (l1..h1 by st1 width wd1) and + ! (l2..h3 by st2 width wd2) giving sequence a(1:n) of indices of second sequence + ! in the first sequence + ! - array a must have enough space + !============================================================================= subroutine overlap_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) integer(pm_ln),intent(in):: l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2 integer(pm_ln),dimension(*),intent(out):: a @@ -5481,6 +5676,13 @@ subroutine overlap_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) n=k-1 end subroutine overlap_bseq + !============================================================================= + ! Overlap two blocked sequences (l1..h1 by st1 width wd1) and + ! (l2..h3 by st2 width wd2) giving sequences a1(1:n) of indices of second sequence + ! in the first sequence and a2(1:n) of indices of first sequence in the second + ! sequence + ! - arrays a1 and a2 must have enough space + !============================================================================= subroutine overlap_bseq2(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a1,a2,n) integer(pm_ln),intent(in):: l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2 integer(pm_ln),dimension(*),intent(out):: a1,a2 @@ -5617,6 +5819,11 @@ subroutine overlap_bseq2(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a1,a2,n) n=k-1 end subroutine overlap_bseq2 + !============================================================================= + ! Replace each element x of a1(1:n1) by x+lo..x+hi creating sequence a2(1:n2) + ! eliminating any repeating elements + ! - a2 must have enough space + !============================================================================= subroutine expand_aseq(a1,n1,lo,hi,a2,n2) integer(pm_ln),dimension(*),intent(in):: a1 integer(pm_ln),intent(in):: n1,lo,hi @@ -5690,7 +5897,11 @@ subroutine interior_index_aseq(a1,lo,hi,a2,n) a2(i)=k enddo end subroutine interior_index_aseq - + + !============================================================================= + ! Intersecrion of two sequences (l1..u1 by s1) with length n1 and + ! (l2..u2 by s2) with length n2 giving sequence (l3..u3 by s3) of length n3 + !============================================================================= subroutine intersect_seq(l1,u1,s1,n1,l2,u2,s2,n2,l3,u3,s3,n3) integer(pm_ln),intent(in):: l1,u1,s1,n1,l2,u2,s2,n2 integer(pm_ln),intent(out):: l3,u3,s3,n3 @@ -5741,6 +5952,10 @@ subroutine intersect_seq(l1,u1,s1,n1,l2,u2,s2,n2,l3,u3,s3,n3) endif end subroutine intersect_seq + !============================================================================= + ! Extended GCD algorithm + ! find g, u and v such that ua + vb = g + !============================================================================= subroutine extended_gcd(a,b,u,v,g) integer(pm_ln),intent(in):: a,b integer(pm_ln),intent(out):: u,v,g @@ -5770,7 +5985,5 @@ subroutine extended_gcd(a,b,u,v,g) g=old_r end subroutine extended_gcd - - end module pm_array diff --git a/src/ast.f90 b/src/ast.f90 index 0478f73..b97cbc9 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -107,17 +107,18 @@ module pm_ast integer,parameter:: proccall_is_comm= 1 integer,parameter:: proccall_is_ref = 2 integer,parameter:: proccall_is_general = 4 - integer,parameter:: proccall_is_yield = 8 + integer,parameter:: proccall_is_block = 8 integer,parameter:: proccall_is_inline= 16 integer,parameter:: proccall_is_no_inline= 32 + integer,parameter:: proccall_is_yield= 64 integer,parameter:: proc_is_cond= 256 integer,parameter:: proc_is_uncond= 512 - integer,parameter:: proc_run_complete= 2**10 - integer,parameter:: proc_run_local= 2**11 - integer,parameter:: proc_run_shared= 2**12 - integer,parameter:: proc_run_always= 2**13 +!!$ integer,parameter:: proc_run_complete= 2**10 +!!$ integer,parameter:: proc_run_local= 2**11 +!!$ integer,parameter:: proc_run_shared= 2**12 +!!$ integer,parameter:: proc_run_always= 2**13 integer,parameter:: proc_is_open= 2**14 integer,parameter:: proc_is_abstract= 2**15 integer,parameter:: proc_is_generator = 2**16 diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 2fa7e2b..e3c850c 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -116,10 +116,9 @@ module pm_cnodes integer,parameter:: call_nret=cnode_args+7 integer,parameter:: call_key_names=cnode_args+8 integer,parameter:: call_index=cnode_args+9 - integer,parameter:: call_par_depth=cnode_args+10 - integer,parameter:: call_var=cnode_args+11 - integer,parameter:: call_amp=cnode_args+12 - integer,parameter:: call_node_size=13 + integer,parameter:: call_var=cnode_args+10 + integer,parameter:: call_amp=cnode_args+11 + integer,parameter:: call_node_size=12 ! Offsets into var cnodes integer,parameter:: var_parent=cnode_args+0 @@ -127,11 +126,9 @@ module pm_cnodes integer,parameter:: var_flags=cnode_args+2 integer,parameter:: var_link=cnode_args+3 integer,parameter:: var_index=cnode_args+4 - integer,parameter:: var_par_depth=cnode_args+5 - integer,parameter:: var_create_depth = cnode_args + 6 - integer,parameter:: var_lex_scope = cnode_args + 7 - integer,parameter:: var_node_size=8 - integer,parameter:: var_extra_info=cnode_args+8 + integer,parameter:: var_lex_scope = cnode_args + 5 + integer,parameter:: var_node_size=6 + integer,parameter:: var_extra_info=cnode_args+6 ! Flags for var cnodes integer,parameter:: var_is_var=1 @@ -145,11 +142,8 @@ module pm_cnodes integer,parameter:: var_is_key=512 integer,parameter:: var_is_varg=1024 integer,parameter:: var_is_par_var=2048 - integer,parameter:: var_is_incomplete=4096 - integer,parameter:: var_is_aliased=8192 - integer,parameter:: var_is_not_inited=16384 - integer,parameter:: var_is_no_import_export=32768 - integer,parameter:: var_is_sync=65536 + integer,parameter:: var_is_not_inited=4096 + integer,parameter:: var_is_maybe_not_private=8192 ! Offsets into proc & builtin nodes integer,parameter:: pr_ptype=cnode_args+0 @@ -179,10 +173,14 @@ module pm_cnodes integer,parameter:: bi_id=cnode_args+9 integer,parameter:: bi_node_size=10 - integer(pm_p),parameter:: spsig_thru=-4_pm_p - integer(pm_p),parameter:: spsig_dup=-5_pm_p - integer(pm_p),parameter:: spsig_noop=-6_pm_p - + ! Special signatures + integer,parameter:: sp_sig_in_process=-1_pm_p + integer,parameter:: sp_sig_recursive=-2_pm_p + integer,parameter:: sp_sig_break=-3_pm_p + integer,parameter:: sp_sig_link=-4_pm_p + integer,parameter:: sp_sig_dup=-5_pm_p + integer,parameter:: sp_sig_noop=-6_pm_p + integer,parameter:: sp_sig_setval=-7_pm_p contains @@ -571,7 +569,7 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) character(len=120):: str,location signo=cnode_get_num(cnode,call_sig) if(signo<0) then - str=repeat(' ',depth)//trim(pm_int_as_string(cnode_get_num(cnode,call_par_depth)+1))//' '//pm_name_as_string(context,-signo) + str=repeat(' ',depth)//pm_name_as_string(context,-signo) i=len_trim(str)+1 if(.not.pm_fast_isnull(rvec)) then k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) @@ -600,13 +598,13 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) str=repeat(' ',depth)//'call '//pm_name_as_string(context,name) else k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) - if(k==spsig_thru) then - str=repeat(' ',depth)//'call [thru]'//& + if(k==sp_sig_link) then + str=repeat(' ',depth)//'call [link]'//& pm_name_as_string(context,name) - elseif(k==spsig_dup) then + elseif(k==sp_sig_dup) then str=repeat(' ',depth)//'call [dup]'//& pm_name_as_string(context,name) - elseif(k==spsig_noop) then + elseif(k==sp_sig_noop) then str=repeat(' ',depth)//'call [noop]'//& pm_name_as_string(context,name) elseif(k<0) then @@ -717,6 +715,9 @@ recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth, call append_to_line(iunit,str,i,& '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) endif + if(cnode_flags_set(cnode,var_flags,var_is_maybe_not_private)) then + call append_to_line(iunit,str,i,'^',.false.,depth) + endif case(cnode_is_const) call append_to_line(iunit,str,i,& trim(pm_value_as_string(context,cnode_arg(cnode,1))),.false.,depth) @@ -771,18 +772,6 @@ subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) endif if(flags/=iand(flags,proccall_is_comm)) then call append_to_line(iunit,str,i,'<',.false.,depth) - if(iand(flags,proc_run_complete)/=0) then - call append_to_line(iunit,str,i,'C',.false.,depth) - endif - if(iand(flags,proc_run_local)/=0) then - call append_to_line(iunit,str,i,'L',.false.,depth) - endif - if(iand(flags,proc_run_shared)/=0) then - call append_to_line(iunit,str,i,'S',.false.,depth) - endif - if(iand(flags,proc_run_always)/=0) then - call append_to_line(iunit,str,i,'A',.false.,depth) - endif if(iand(flags,proccall_is_inline)/=0) then call append_to_line(iunit,str,i,'I',.false.,depth) endif diff --git a/src/codegen.f90 b/src/codegen.f90 index 662fa85..32de0a6 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2024 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -17,7 +17,7 @@ ! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT IN NO EVENT SHALL THE ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN @@ -62,47 +62,19 @@ module pm_codegen ! Limits integer,parameter:: max_code_stack=4096 integer,parameter:: code_local_hash=1024 - integer,parameter:: max_par_depth=256 + integer,parameter:: max_trace_depth=256 integer,parameter:: max_type_nesting=64 integer,parameter:: max_error_nodes=1024 - ! Flags indicating state within parallel statement nesting - integer,parameter:: par_state_nhd=0 - integer,parameter:: par_state_outer=1 - integer,parameter:: par_state_for=2 - integer,parameter:: par_state_loop=3 - integer,parameter:: par_state_cond_loop=4 - ! -- The following are conditional states (can check >=par_state_cond) - integer,parameter:: par_state_cond=5 - integer,parameter:: par_state_par=6 - integer,parameter:: par_state_masked=7 - integer,parameter:: par_state_over=8 - integer,parameter:: par_state_any=9 - integer,parameter:: par_state_labelled=10 - - ! Reference flags - integer,parameter:: ref_is_val=1 - integer,parameter:: ref_ignores_rules=2 - integer,parameter:: ref_is_dollar=4 - integer,parameter:: ref_is_priv=8 - integer,parameter:: ref_is_shared=16 - integer,parameter:: ref_is_subscripted=32 - integer,parameter:: ref_has_at=64 - integer,parameter:: ref_is_amp=256 - - ! Offsets for loop variables - integer,parameter:: lv_dom=-3 - integer,parameter:: lv_prc=-2 - integer,parameter:: lv_distr=-1 - integer,parameter:: lv_tile=0 - integer,parameter:: lv_num=1 - integer,parameter:: lv_numz=2 - integer,parameter:: lv_index=5 - integer,parameter:: lv_here=6 - integer,parameter:: lv_end=1 - integer,parameter:: lv_state=2 - integer,parameter:: lv_last=3 - integer,parameter:: lv_idx=3 + + ! Parallel context + integer,parameter:: par_state_none=0 + integer,parameter:: par_state_for=1 + integer,parameter:: par_state_comm_proc=2 + integer,parameter:: par_state_masked=3 + integer,parameter:: par_state_cond=4 + integer,parameter:: par_state_par=5 + integer,parameter:: par_state_sync=6 ! Flags indicating start/end of a block of type variables ! as opposed to regular variables on variables stack @@ -124,7 +96,7 @@ module pm_codegen type(pm_ptr):: visibility ! Stack for local variables (stack() for names, var() for info records) - integer,dimension(max_code_stack):: stack,imps + integer,dimension(max_code_stack):: stack type(pm_ptr),dimension(max_code_stack):: var integer:: top @@ -142,12 +114,6 @@ module pm_codegen ! Flags for current procedure integer:: proc_flags - ! for & par statements - import/export - type(pm_ptr):: loop_cblock - type(pm_ptr),dimension(max_par_depth):: import_cblock - integer:: par_depth,proc_par_depth - integer:: par_base,over_base - ! State variables (as position in coder%var) integer:: state_base,mask @@ -162,7 +128,9 @@ module pm_codegen type(pm_ptr):: proc_name_vals ! Misc values - type(pm_ptr):: temp,temp2,true,false,one,comm_amp,std_amp,check_mess,undef_val + type(pm_ptr):: temp,temp2,true,false,one,comm_amp + type(pm_ptr):: std_amp,block_amp,iter_amps,iter_block_amps + type(pm_ptr):: check_mess,undef_val ! 'true and 'false types integer:: true_fix,false_fix,true_literal,false_literal @@ -171,14 +139,10 @@ module pm_codegen integer:: unit_type ! Contextual information for this point in the traverse - type(pm_ptr):: proc, proc_keys - integer:: proc_base,proc_nret,proc_key_base,proc_ncalls - integer:: run_mode,run_flags,par_state - type(pm_ptr):: label,default_label - logical:: fixed,aliased,in_sync - - ! This point in a subscript tuple - integer:: subs_index + type(pm_ptr):: proc + integer:: proc_base,proc_ncalls + logical:: fixed + integer:: par_state ! Counter to give each proc a unique index for all procs integer:: id @@ -189,7 +153,7 @@ module pm_codegen ! Counter to provide unique index for all blocks integer:: block_id - ! Nesting depth of if statements (offset into vstack) + ! Lexical scope (offset into vstack) integer:: lex_scope ! Blocks @@ -203,16 +167,13 @@ module pm_codegen ! Type inference base of current proc record integer:: base - - ! This is the parallel kind storeageless implicit argument - integer:: par_kind,par_kind2 ! Type inference flag recursion -- use to locate infinite recursion logical:: flag_recursion ! Type inference procedure trace - type(pm_ptr),dimension(max_par_depth):: trace - integer,dimension(max_par_depth)::trace_keys + type(pm_ptr),dimension(max_trace_depth):: trace + integer,dimension(max_trace_depth)::trace_keys integer:: trace_depth ! Error count @@ -228,7 +189,6 @@ module pm_codegen ! SETUP !******************************************************** - !======================================================== ! Initialise code generator structure !======================================================== @@ -236,8 +196,6 @@ subroutine init_coder(context,coder,visibility) type(pm_context),pointer:: context type(pm_ptr),intent(in):: visibility type(code_state),intent(out):: coder - type(pm_ptr):: sig - integer:: sym coder%context=>context coder%visibility=visibility coder%top=1 @@ -248,8 +206,10 @@ subroutine init_coder(context,coder,visibility) coder%undef_val,& array=coder%var,array_size=coder%top) coder%reg2=>pm_register(context,'coder-node stack',& - coder%proc_name_vals,coder%poly_cache,coder%comm_amp,coder%std_amp,array=& - coder%vstack,array_size=coder%vtop) + coder%proc_name_vals,coder%poly_cache,coder%comm_amp,& + coder%std_amp,coder%block_amp,coder%iter_amps,& + coder%iter_block_amps,array=coder%vstack,& + array_size=coder%vtop) coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check,& coder%check_mess) coder%sig_cache=pm_dict_new(context,32_pm_ln) @@ -257,15 +217,6 @@ subroutine init_coder(context,coder,visibility) coder%defer_check=pm_null_obj coder%proc_base=1 coder%proc_ncalls=0 - coder%par_base=0 - coder%over_base=0 - coder%par_depth=0 - coder%proc_par_depth=0 - coder%par_state=par_state_outer - coder%run_mode=sym_private - coder%run_flags=0 - coder%loop_cblock=pm_null_obj - coder%proc_keys=pm_null_obj coder%index=0 coder%lex_scope=0 coder%true=pm_new_small(context,pm_logical,1_pm_p) @@ -275,7 +226,7 @@ subroutine init_coder(context,coder,visibility) coder%one=pm_new_small(context,pm_long,1_pm_p) coder%one%data%ln(coder%one%offset)=1 - coder%unit_type=pm_new_fix_type(coder%context,coder%one) + coder%unit_type=pm_new_fix_value_type(coder%context,coder%one) coder%one=pm_new_small(context,pm_int,1_pm_p) coder%one%data%i(coder%one%offset)=1 @@ -283,41 +234,43 @@ subroutine init_coder(context,coder,visibility) coder%comm_amp%data%i(coder%comm_amp%offset)=num_comm_args+1 coder%std_amp=pm_new_small(context,pm_int,1_pm_p) coder%std_amp%data%i(coder%std_amp%offset)=2 - + coder%block_amp=pm_new_small(context,pm_int,1_pm_p) + coder%block_amp%data%i(coder%block_amp%offset)=num_comm_args+2 + coder%iter_amps=pm_new_small(context,pm_int,2_pm_p) + coder%iter_amps%data%i(coder%iter_amps%offset)=num_comm_args+2 + coder%iter_amps%data%i(coder%iter_amps%offset+1)=num_comm_args+4 + coder%iter_block_amps=pm_new_small(context,pm_int,2_pm_p) + coder%iter_block_amps%data%i(coder%iter_block_amps%offset)=num_comm_args+1 + coder%iter_block_amps%data%i(coder%iter_block_amps%offset+1)=num_comm_args+3 coder%one=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%one)) coder%comm_amp=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%comm_amp)) coder%std_amp=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%std_amp)) + coder%block_amp=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%block_amp)) + coder%iter_amps=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%iter_amps)) + coder%iter_block_amps=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%iter_block_amps)) coder%check_mess=pm_new_string(coder%context,'Failed "check" or "test""') coder%proc_name_vals=pm_dict_new(coder%context,8_pm_ln) coder%id=0 coder%block_id=0 - coder%true_fix=pm_new_fix_type(coder%context,coder%true) - coder%false_fix=pm_new_fix_type(coder%context,coder%false) - coder%true_literal=pm_new_literal_type(coder%context,coder%true) - coder%false_literal=pm_new_literal_type(coder%context,coder%false) + coder%true_fix=pm_new_fix_value_type(coder%context,coder%true) + coder%false_fix=pm_new_fix_value_type(coder%context,coder%false) + coder%true_literal=pm_new_literal_value_type(coder%context,coder%true) + coder%false_literal=pm_new_literal_value_type(coder%context,coder%false) - coder%default_label=pm_fast_name(coder%context,sym_pct) - coder%label=coder%default_label coder%num_errors=0 coder%supress_errors=.false. coder%fixed=.false. - coder%aliased=.false. - coder%in_sync=.false. - coder%subs_index=-1 + coder%par_state=par_state_none contains include 'fname.inc' include 'ftiny.inc' - - function name_type(n) result(u) - integer,intent(in):: n - integer:: u - u=pm_new_name_type(coder%context,n) - end function name_type - end subroutine init_coder !======================================================== @@ -337,7 +290,6 @@ subroutine trav_prog(coder,stmt_list) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: stmt_list type(pm_ptr):: prog_cblock - integer:: i prog_cblock=make_cblock(coder,pm_null_obj,stmt_list,sym_do) coder%prog_cblock=prog_cblock @@ -353,7 +305,6 @@ subroutine trav_prog(coder,stmt_list) ! filesystem variable call make_sys_var(coder,prog_cblock,stmt_list,sym_filesystem,var_is_var) call make_sys_call(coder,prog_cblock,stmt_list,sym_get_filesystem,0,1) - call make_var_mode(coder,prog_cblock,stmt_list,coder%var(coder%top)) call trav_stmt_list(coder,prog_cblock,stmt_list,stmt_list,sym_do) call make_sp_call(coder,prog_cblock,stmt_list,sym_do,1,0) @@ -399,10 +350,9 @@ subroutine make_state_vars(coder,cblock,node,topo) end subroutine make_state_vars !******************************************************* - ! SEQUENTIAL STATEMENTS + ! STATEMENTS !******************************************************* - !======================================================== ! Traverse statement list - push cblock onto stack !======================================================== @@ -425,10 +375,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& listp,list) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,listp,list - integer:: i,j,n,sym,base,vbase,wbase,lex_scope - integer:: save_par_state,save_over_base,save_run_flags + integer:: i,j,n,sym,base,vbase,wbase,lex_scope,save_par_state type(pm_ptr):: node,cblock2,var,p - logical:: iscomm,isshared,ok,oldfix + logical:: iscomm if(pm_fast_isnull(list)) goto 10 do i=1,node_numargs(list) vbase=coder%vtop @@ -440,17 +389,17 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& !call dump_parse_tree(coder%context,6,node,2) endif select case(sym) - case(sym_if) - save_par_state=coder%par_state + case(sym_if,sym_if_invar) lex_scope=push_lex_scope(coder) + save_par_state=coder%par_state call trav_xexpr(coder,cblock,node,& node_arg(node,1)) - if(coder%par_state>par_state_outer) then - if(pm_fast_isnull(node_arg(node,3))) then - coder%par_state=par_state_masked - else - coder%par_state=par_state_cond - endif + if(sym==sym_if_invar) then + call code_check_invar(coder,cblock,node,top_code(coder),sym_if_invar) + else + coder%par_state=merge(merge(par_state_masked,par_state_cond,& + pm_fast_isnull(node_arg(node,3))),par_state_none,& + coder%par_state/=par_state_none) endif coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& @@ -461,71 +410,40 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif + coder%par_state=save_par_state call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,& sym_if,4,0) call pop_lex_scope(coder) - coder%par_state=save_par_state - case(sym_if_invar) - if(coder%par_state>=par_state_cond) then - call code_error(coder,node,& - 'Cannot have "if invar" in a conditional context') - endif - lex_scope=push_lex_scope(coder) + case(sym_switch,sym_switch_invar) call trav_xexpr(coder,cblock,node,& node_arg(node,1)) - call code_check_invar(coder,cblock,node,top_code(coder)) - coder%lex_scope=lex_scope - call trav_stmt_list(coder,cblock,node,& - node_arg(node,2),sym_if_invar) - if(.not.pm_fast_isnull(node_arg(node,3))) then - call trav_stmt_list(coder,cblock,& - node,node_arg(node,3),sym_if_invar) + save_par_state=coder%par_state + if(sym==sym_switch_invar) then + call code_check_invar(coder,cblock,node,top_code(coder),sym_switch_invar) else - call code_null(coder) + coder%par_state=merge(merge(par_state_masked,par_state_cond,& + pm_fast_isnull(node_arg(node,node_numargs(node)))),par_state_none,& + coder%par_state/=par_state_none) endif - call get_lex_scope(coder,node) - call make_sp_call(coder,cblock,node,sym,4,0) - call pop_lex_scope(coder) - case(sym_switch) - save_par_state=coder%par_state - call trav_xexpr(coder,cblock,node,& - node_arg(node,1)) var=top_code(coder) - if(save_par_state>par_state_outer) then - if(node_numargs(node)==4) then - if(pm_fast_isnull(node_arg(node,4))) then - coder%par_state=par_state_masked - else - coder%par_state=par_state_cond - endif - else - coder%par_state=par_state_cond - endif - endif - call trav_switch_stmt(coder,cblock,node,2,var,sym_if) + call trav_switch_stmt(coder,cblock,node,2,var,& + merge(sym_if_invar,sym_if,sym==sym_switch_invar)) call drop_code(coder) coder%par_state=save_par_state - case(sym_switch_invar) - if(coder%par_state>=par_state_cond) then - call code_error(coder,node,& - 'Cannot have "switch invar" in a conditional context') - endif - call trav_xexpr(coder,cblock,node,& - node_arg(node,1)) - call code_check_invar(coder,cblock,node,top_code(coder)) - call trav_switch_stmt(coder,cblock,node,2,var,sym_if_invar) - call drop_code(coder) case(sym_while,sym_while_invar) - save_par_state=coder%par_state lex_scope=push_lex_scope(coder) + save_par_state=coder%par_state + if(sym==sym_while) then + coder%par_state=merge(par_state_cond,par_state_none,& + coder%par_state/=par_state_none) + endif cblock2=make_cblock(coder,cblock,node,sym_while) call trav_xexpr(coder,cblock2,node,node_arg(node,1)) if(sym==sym_while_invar) then - call code_check_invar(coder,cblock2,node,top_code(coder)) + call code_check_invar(coder,cblock2,node,top_code(coder),sym_while_invar) endif call close_cblock(coder,cblock2) - coder%par_state=save_par_state coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& node_arg(node,2),sym_while) @@ -534,8 +452,12 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_until,sym_until_invar) - lex_scope=push_lex_scope(coder) save_par_state=coder%par_state + if(sym==sym_until) then + coder%par_state=merge(par_state_cond,par_state_none,& + coder%par_state/=par_state_none) + endif + lex_scope=push_lex_scope(coder) cblock2=make_cblock(coder,cblock,node,sym_until) coder%lex_scope=lex_scope call trav_open_stmt_list(coder,cblock2,node,& @@ -543,14 +465,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& iscomm=cnode_flags_set(top_code(coder),cblock_flags,cblock_is_comm) call trav_xexpr(coder,cblock2,node,node_arg(node,1)) if(sym==sym_until_invar) then - call code_check_invar(coder,cblock2,node,top_code(coder)) + call code_check_invar(coder,cblock2,node,top_code(coder),sym_until_invar) endif call close_cblock(coder,cblock2) - do j=coder%vtop-1,coder%vtop - write(*,*) '++++++++++++++++',j - call qdump_code_tree(coder,pm_null_obj,6,coder%vstack(j),2) - enddo - write(*,*) '+++++++++++++++++++++' call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,& sym_until,3,0) @@ -561,20 +478,24 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) call make_sp_call(coder,cblock,node,sym_do,1,0) else - call make_block_proc(coder,cblock,node,& + call make_block_proc(coder,cblock,node_arg(node,3),& node_arg(node,1),node_num_arg(node,2),& - pm_null_obj,0,& + node_arg(node,5),node_numargs(node_arg(node,5)),& node_arg(node,4)) call trav_call(coder,cblock,node,node_arg(node,3),0,.true.) endif case(sym_proceed) continue - case(sym_mode) - call trav_mode_stmt(coder,cblock,node,sym,.false.) - case(sym_for) - call trav_xexpr(coder,cblock,node,node_arg(node,2),node) + case(sym_invar) + call trav_mode_stmt(coder,cblock,node,sym,sym_invar_stmt) + case(sym_shared) + call trav_mode_stmt(coder,cblock,node,sym,sym_shared_stmt) + case(sym_chan) + call trav_mode_stmt(coder,cblock,node,sym,sym_chan_stmt) + case(sym_for,sym_forall) + call trav_for_stmt(coder,cblock,list,node) case(sym_each,sym_foreach_invar) - call trav_xexpr(coder,cblock,node,node_arg(node,1),node) + call trav_foreach_stmt(coder,cblock,list,node) case(sym_test) if(pm_fast_isnull(node_arg(node,1))) then call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_check) @@ -592,8 +513,8 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& p=node_arg(node,1) call trav_call(coder,cblock,node,p,0,.true.) case(sym_var,sym_const) - do j=1,node_numargs(node)-1 - call make_var(coder,cblock,node,node_arg(node,j),& + do j=1,node_numargs(node)-2 + call make_var(coder,cblock,node,node_num_arg(node,j),& ior(var_is_not_inited,& merge(var_is_var,0,sym==sym_var))) enddo @@ -606,53 +527,18 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call make_type(coder,3) call code_num(coder,pop_word(coder)) call make_sp_call(coder,cblock,node,sym_var,node_numargs(node)-1,1) - case(sym_with) - base=coder%top - call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) - j=coder%top - call trav_open_stmt_list(coder,cblock,node,node_arg(node,2)) - call hide_vars(coder,base+1,j) case(sym_over) -! call trav_over_stmt(coder,cblock,list,node) + call trav_over_stmt(coder,cblock,list,node) case(sym_assign) call trav_assign_define(coder,cblock,list,node) case(sym_assign_list) call trav_assign_define_list(coder,cblock,list,node) - case(sym_sync_assign) - call trav_sync_assign(coder,cblock,list,node) - case(sym_where,sym_check,sym_amp) + case(sym_all) + call trav_all_stmt(coder,cblock,list,node) + case(sym_where,sym_distinct,sym_check,sym_amp) call trav_xexpr(coder,cblock,listp,node) case(sym_sync) - select case(coder%par_state) - case(par_state_cond,par_state_par) - save_par_state=coder%par_state - coder%par_state=par_state_labelled - call check_par_context(coder,cblock,node,.false.) - coder%label=node_arg(node,2) - call make_const(coder,cblock,node,& - node_arg(node,2)) - call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_sync) - call make_sp_call(coder,cblock,node,sym_sync,2,0) - coder%par_state=save_par_state - coder%label=coder%default_label - case(par_state_outer) - call code_error(coder,node,& - 'Labelled statement not allowed outside of any parallel statement') - case(par_state_nhd) - call code_error(coder,node,& - 'Labelled statement not allowed in a "nhd" statement') - case(par_state_any) - call code_error(coder,node,& - 'Labelled statement not allowed in an "any" statement') - case(par_state_cond_loop) - call code_error(coder,node,& - 'Labelled statement in unlabelled loop') - case(par_state_for,par_state_loop,par_state_masked,par_state_over,par_state_labelled) - call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) - case default - write(*,*) 'Par state=',coder%par_state - call pm_panic('Unknown par state (sym_sync)') - end select + call trav_sync_stmt(coder,cblock,list,node) case(sym_par) ! call trav_par_stmt(coder,cblock,list,node) case(sym_any,sym_any_invar) @@ -689,11 +575,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call trav_expr(coder,cblock,node,node_arg(node,2)) if(j==3) call trav_expr(coder,cblock,node,node_arg(node,3)) - if(coder%par_state==par_state_outer) then - call make_sys_call(coder,cblock,node,sym_pm_dump,j-1,0) - else - call make_comm_sys_call(coder,cblock,node,sym_pm_dump,j-1,0) - endif + call make_comm_sys_call(coder,cblock,node,sym_pm_dump,j-1,0) endif case default call code_error(coder,node,'Pragma not recognised: $$'//& @@ -703,7 +585,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& base=coder%vtop call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& var_is_shadowed) - call set_var_as_shared(coder,top_code(coder)) call dup_code(coder) call make_sys_var(coder,cblock,node,node_get_num(node,node_args+1),& var_is_shadowed) @@ -726,8 +607,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call make_sp_call(coder,cblock,node,sym,5,3) call close_cblock(coder,cblock2) endif - call set_var_as_shared(coder,pop_code(coder)) - call check_par_context(coder,cblock,node,.false.) if(coder%vtop/=base) call pm_panic('pm_send/recv') case(sym_pm_bcast) call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& @@ -739,7 +618,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_expr(coder,cblock,node,node_arg(node,5)) call trav_stmt_list(coder,cblock,node,node_arg(node,6),sym_caret) call make_sp_call(coder,cblock,node,sym,4,2) - call check_par_context(coder,cblock,node,.false.) case(sym_pm_recv_req) call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& var_is_shadowed) @@ -781,9 +659,47 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& enddo call trav_stmt_list(coder,cblock,node,node_arg(node,node_numargs(node)),sym_caret) call make_sp_call(coder,cblock,node,sym,node_numargs(node),0) + case(sym_pm_each_index) + call trav_pm_each_index(coder,cblock,list,node,.false.) + case(sym_pm_context) + call trav_pm_context(coder,cblock,list,node) + case(sym_pm_set_dotdotdot) + call make_sys_var(coder,cblock,list,sym_dotdotdot,var_is_param+var_is_varg) + call trav_expr(coder,cblock,list,node_arg(node,1)) + call make_sp_call(coder,cblock,list,sym_pm_set_dotdotdot,1,1) case(sym_pm_head_node) call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_caret) call make_sp_call(coder,cblock,node,sym,1,0) + case(sym_pm_over) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_pm_for) + call make_sp_call(coder,cblock,node,sym,2,0) + case(sym_pm_for) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + save_par_state=coder%par_state + coder%par_state=par_state_for + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_pm_for) + coder%par_state=save_par_state + call make_sp_call(coder,cblock,node,sym,2,0) + case(sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) + save_par_state=coder%par_state + ! Assumes test correctly separates shared/chan + coder%par_state=merge(par_state_for,par_state_none,sym>=sym_pm_chan) + call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym) + coder%par_state=save_par_state + call make_sp_call(coder,cblock,node,sym,1,0) + case(sym_pm_foreach) + lex_scope=push_lex_scope(coder) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + coder%lex_scope=lex_scope + save_par_state=coder%par_state + coder%par_state=par_state_masked + call trav_stmt_list(coder,cblock,node,& + node_arg(node,2),sym_pm_foreach) + coder%par_state=save_par_state + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,sym_pm_foreach,3,0) + call pop_lex_scope(coder) case default if(sym>0.and.sym1) then + call make_sys_call_rtn(coder,cblock,stmt,& + sym_or,2,1) + endif + enddo + coder%vstack(base+1)=top_code(coder) + coder%vtop=base+1 + if(sym==sym_if_invar) then + call code_check_invar(coder,cblock,stmt,top_code(coder),sym_switch_invar) + endif + coder%lex_scope=lex_scope + call trav_stmt_list(coder,cblock,stmt,& + node_arg(stmt,idx+1),sym_switch) + if(idx==node_numargs(stmt)-2) then + if(pm_fast_isnull(node_arg(stmt,idx+2))) then + call code_null(coder) + else + call trav_stmt_list(coder,cblock,stmt,& + node_arg(stmt,idx+2),sym_switch) + endif + else + cblock2=make_cblock(coder,cblock,stmt,sym_switch) + call trav_switch_stmt(coder,cblock2,stmt,idx+2,var,sym) + call close_cblock(coder,cblock2) + endif + call get_lex_scope(coder,stmt) + call make_sp_call(coder,cblock,stmt,sym,4,0) + call pop_lex_scope(coder) + contains + include 'fisnull.inc' + end subroutine trav_switch_stmt - !=================================== - ! Exit lexical scope - ! Pops record off the top of vstack - !=================================== - subroutine pop_lex_scope(coder) + !======================================================== + ! Traverse "any" statement (sym is "any" or "any invar") + !======================================================== + recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) type(code_state),intent(inout):: coder - coder%lex_scope=coder%vstack(coder%vtop-2)%offset - call drop_code(coder) - call drop_code(coder) - call drop_code(coder) - end subroutine pop_lex_scope + type(pm_ptr),intent(in):: cblock,pnode,node + integer,intent(in):: sym + integer:: flags,start,finish,vb,lex_scope + type(pm_ptr):: cblock2,v,var - !========================================== - ! Record read or write (if modify is true) - ! access to a variable - !=========================================== - subroutine access_var(coder,var,modify) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(inout):: var - logical,intent(in):: modify - if(coder%block_base>0) write(*,*) 'access var',modify,& - trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))),& - cnode_get_num(var,var_index) - if(modify) then - call cnode_set_flags(var,var_flags,var_is_changed) + lex_scope=push_lex_scope(coder) + + if(pm_fast_isnull(node_arg(node,2))) then + flags=var_is_shadowed+var_is_var + call trav_expr(coder,cblock,node,node_arg(node,1)) else - if(cnode_flags_set(var,var_flags,var_is_accessed)) then - call cnode_set_flags(var,var_flags,var_is_multi_access) + flags=var_is_var + call trav_xexpr(coder,cblock,node,node_arg(node,2)) + endif + v=top_code(coder) + if(sym==sym_any_invar) then + call code_check_invar(coder,cblock,node,v,sym_any_invar) + endif + cblock2=make_cblock(coder,cblock,node,sym_any) + call make_var(coder,cblock,node,node_num_arg(node_arg(node,1),1),flags) + vb=coder%top + var=top_code(coder) + start=coder%index + call swap_code(coder) + coder%lex_scope=lex_scope + call trav_open_stmt_list(coder,cblock2,node,node_arg(node,3)) + if(cnode_flags_set(var,var_flags,var_is_changed)) then + call code_val(coder,var) + call dup_expr(coder,v) + call make_sys_call_rtn(coder,cblock2,node,sym_as,2,1) + call hide_vars(coder,vb,vb) + if(pm_fast_isnull(node_arg(node,2))) then + call make_assignment_noalias(coder,cblock2,node,node_arg(node,1)) else - call cnode_set_flags(var,var_flags,var_is_accessed) + call make_assignment_noalias(coder,cblock2,node,node_arg(node,2)) endif + call reveal_vars(coder,vb,vb) endif - call update_change_lists(coder,var,modify) - end subroutine access_var - - !============================================= - ! Add var to the change list for all if scopes - ! that are nested inside the scope in which - ! the variable was defined - !============================================= - subroutine update_change_lists(coder,var,modify) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical,intent(in):: modify - integer:: lex_scope,lex_scope_of_var - lex_scope=coder%lex_scope - lex_scope_of_var=cnode_get_num(var,var_lex_scope) - do while(var_lex_scope=0) call hide_vars(coder,base+1,xtop) + + call make_full_sys_call(coder,cblock2,node,sym_pm_foreach_stmt,6,0,amps,pm_null_obj,& + pm_null_obj,proccall_is_comm+proccall_is_general) + + if(node_sym(condition)==sym_while) then + call close_cblock(coder,cblock2) + call code_null(coder) + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,& + sym_if,4,0) + call pop_lex_scope(coder) + endif + + contains + include 'fisnull.inc' + end subroutine trav_foreach_stmt + + !==================================================================== + ! Traverse a for or forall statement node + ! - designed to be called indirectly by xexpr, which is used + ! to compute subexpressions covering iterators and attributes + ! - assumes variables from base to current top are 'where' variables + ! in the subexpression + !==================================================================== + subroutine trav_for_stmt(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: stmts,iter,amps,keys,keynames + integer:: i,base,xtop + + amps=coder%iter_amps + iter=node_arg(node,1) + keys=node_arg(node,2) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) + endif + stmts=node_arg(node,4) + + call make_block_proc(coder,cblock,node_arg(node,1),pm_null_obj,& + int(coder%iter_block_amps%offset),pm_null_obj,0,stmts,iter,.true.,.true.) + + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop) + + call make_iter_lists(coder,cblock,iter,node_numargs(iter),.true.,.true.) + + call trav_expr(coder,cblock,node,node_arg(iter,2)) + call make_sys_call_rtn(coder,cblock,node,sym_hash,1,1) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC + endif + + if(base>=0) call hide_vars(coder,base+1,xtop) + + call make_full_sys_call(coder,cblock,node,& + merge(sym_pm_for_stmt,sym_pm_forall_stmt,node_sym(node)==sym_for),& + 7,0,amps,keys,keynames,proccall_is_comm+proccall_is_general) + + coder%temp2=pm_null_obj + + contains + include 'fisnull.inc' + end subroutine trav_for_stmt + + !======================================================== + ! Traverse "all" assignment + !======================================================== + recursive subroutine trav_all_stmt(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: base,xtop + if(coder%par_state==par_state_none) then + call code_error(coder,node,& + 'Cannot have an "all" statement outside of a parallel context') + elseif(coder%par_state==par_state_cond.or.coder%par_state==par_state_par) then + call code_error(coder,node,& + 'In a conditional statement, an "all" statement must be enclosed by a "sync" statement') + endif + call trav_subexpr(coder,cblock,node,node_arg(node,4),base,xtop) + call trav_comm_ref(coder,cblock,node,node_arg(node,1),.true.,.false.) + call trav_expr(coder,cblock,node,node_arg(node,2)) + call trav_expr(coder,cblock,node,node_arg(node,3)) + call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3,0) + if(base>=0) call hide_vars(coder,base+1,xtop) + end subroutine trav_all_stmt + + subroutine trav_ref(coder,cblock,pnode,node,islhs,call_sym) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + logical,intent(in):: islhs + integer,intent(in),optional:: call_sym + integer:: n,flags + logical:: maybe_not_private + if(node_sym(node)==sym_name) then + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) + n=1 + elseif(node_sym(node)==sym_reference) then + call trav_ref_to_var(coder,cblock,node,node_num_arg(node_arg(node,1),1),islhs) + flags=cnode_get_num(top_code(coder),var_flags) + maybe_not_private=iand(flags,var_is_maybe_not_private)/=0 + if(maybe_not_private) then + call trav_comm_ref(coder,cblock,pnode,node,islhs,.false.) + n=2 + else + call trav_simple_ref(coder,cblock,pnode,node,islhs) + n=1 + endif + endif + if(present(call_sym)) then + if(coder%par_state==par_state_none) then + call make_sys_call_rtn(coder,cblock,node,call_sym,n,1) + else + call make_comm_sys_call_rtn(coder,cblock,node,call_sym,n,1) + endif + endif + end subroutine trav_ref + + subroutine trav_simple_ref(coder,cblock,pnode,node,islhs) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + logical,intent(in):: islhs + integer:: i,n,m,sym + type(pm_ptr):: arg,list + n=node_numargs(node) + do i=2,n + arg=node_arg(node,i) + sym=node_sym(arg) + select case(sym) + case(sym_dot) + call make_const(coder,cblock,node,node_arg(node,1)) + call make_sp_call_rtn(coder,cblock,node,sym_dot,2,1) + case(sym_sub) + list=node_arg(node,1) + call trav_exprlist(coder,cblock,node,list) + call make_sys_call_rtn(coder,cblock,node,sym_sub,1+node_numargs(list),1) + case(sym_open) + list=node_arg(node,2) + m=node_numargs(list) + call trav_exprlist(coder,cblock,node,list) + call make_arglist(coder,cblock,node,m,1,.false.,.true.) + call code_null(coder) + call trav_expr(coder,cblock,node,node_arg(node,1)) + call make_full_call(coder,cblock,node,pm_fast_tinyint(coder%context,0),& + pm_null_obj,1+m,1,0,pm_null_obj,& + proccall_is_comm+proccall_is_general+proccall_is_ref,pop_code(coder)) + call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1) + end select enddo + contains + include 'ftiny.inc' + end subroutine trav_simple_ref + + subroutine trav_comm_ref(coder,cblock,pnode,node,islhs,isaliased) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + logical,intent(in):: islhs,isaliased + type(pm_ptr):: arg + integer:: i,j,n,sym + i=1 + n=node_numargs(node) + + if(node_sym(node)==sym_reference.and..not.isaliased) then + do while(i<=n) + arg=node_arg(node,i) + sym=node_sym(node) + if(sym==sym_dot) then + call code_val(coder,node_arg(arg,1)) + call make_sp_call_rtn(coder,cblock,node,sym_dot,2,1) + i=i+1 + else + if(i==n) then + if(sym==sym_open_square) then + call trav_exprlist(coder,cblock,node,arg) + call make_comm_sys_call_rtn(coder,cblock,node,sym_sub,node_numargs(arg),1) + else + call trav_exprlist(coder,cblock,node,node_arg(arg,2)) + call make_comm_sys_call_rtn(coder,cblock,node,node_num_arg(arg,1),& + node_numargs(node_arg(arg,2)),1,aflags=proccall_is_ref) + endif + i=i+1 + endif + exit + endif + enddo + endif + + do j=n,i,-1 + arg=node_arg(node,j) + sym=node_sym(arg) + if(sym==sym_dot) then + + elseif(sym==sym_open_square) then + call trav_expr(coder,cblock,node,node_arg(node,1)) + else + call trav_expr(coder,cblock,node,node_arg(node,1)) + endif + call make_sys_call_rtn(coder,cblock,node,sym_pm_list,2,1) + enddo + + end subroutine trav_comm_ref + + subroutine check_alias(coder,cblock,node1,node2,str) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node1,node2 + character(len=*):: str + if(is_aliased(coder,cblock,node1,node2)) then + call code_error(coder,node1,str) + call code_error(coder,node2,'Corresponding variable access for the above error') + endif + end subroutine check_alias + + function is_aliased(coder,cblock,node1,node2) result(aliased) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node1,node2 + logical:: aliased + integer:: i + type(pm_ptr):: arg1,arg2 + if(root_name(node1)/=root_name(node2)) then + aliased=.false. + return + endif + aliased=.true. + do i=2,min(node_numargs(node1),node_numargs(node2)) + arg1=node_arg(node1,i) + arg2=node_arg(node2,i) + if(node_sym(arg1)==sym_dot.and.node_sym(arg2)==sym_dot) then + if(node_num_arg(arg1,1)/=node_num_arg(arg2,1)) then + aliased=.false. + return + endif + else + exit + endif + enddo + end function is_aliased + + !======================================================== + ! Traverse "sync" statement + !======================================================== + recursive subroutine trav_sync_stmt(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: save_par_state + select case(coder%par_state) + case(par_state_none) + call code_error(coder,node,& + 'Cannot have a "sync" statement outside of a parallel context') + case(par_state_for,par_state_comm_proc) + call code_error(coder,node,& + 'Can only have "sync" statements inside a branch of a conditional statement') + case(par_state_sync) + call code_error(coder,node,& + 'Cannot nest "sync" or "sync while" statements inside each other') + end select + save_par_state=coder%par_state + coder%par_state=par_state_sync + call code_val(coder,node_arg(node,1)) + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_sync) + call make_sp_call(coder,cblock,node,sym_sync,2,0) + coder%par_state=save_par_state + end subroutine trav_sync_stmt + + !======================================================== + ! Traverse "sync while" statement + !======================================================== + recursive subroutine trav_sync_while_stmt(coder,cblock,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer:: save_par_state + select case(coder%par_state) + case(par_state_none) + call code_error(coder,node,& + 'Cannot have a "sync while" statement outside of a parallel context') + case(par_state_for,par_state_comm_proc) + call code_error(coder,node,& + 'Can only have "sync while" statements inside a branch of a conditional statement') + case(par_state_sync) + call code_error(coder,node,& + 'Cannot nest "sync" or "sync while" statements inside each other') + end select + save_par_state=coder%par_state + coder%par_state=par_state_sync + !call trav_name(coder,cblock,node,node_num_arg(node,1)) !!! ref to var? + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_sync_while) + call make_sp_call(coder,cblock,node,sym_sync_while,2,0) + coder%par_state=save_par_state + end subroutine trav_sync_while_stmt + + !======================================================== + ! Traverse statement qualified by a mode + !======================================================== + recursive subroutine trav_mode_stmt(coder,cblock,node,sym,call_sym) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: sym,call_sym + integer:: base,xtop + type(pm_ptr):: keynames,keys + + if(coder%par_state==par_state_none) then + call code_error(coder,node,& + 'Cannot have "'//sym_names(sym)//' statement outside of a parallel context') + endif + + keys=node_arg(node,1) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) + endif + + call trav_subexpr(coder,cblock,node,node_arg(node,2),base,xtop) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC + endif + + if(base>=0) call hide_vars(coder,base+1,xtop) + + call make_block_proc(coder,cblock,node,& + pm_null_obj,& + int(coder%comm_amp%offset),pm_null_obj,0,& + node_arg(node,3)) + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + call make_full_sys_call(coder,cblock,node,call_sym,3,0,& + coder%block_amp,keys,keynames,& + proccall_is_comm+proccall_is_general) + + coder%temp2=pm_null_obj contains include 'fisnull.inc' - end subroutine retrieve_change_list + end subroutine trav_mode_stmt + - subroutine make_block_proc(coder,cblock,stmt,namelist,amps,rtns,nret,stmtlist) + !======================================================== + ! Traverse over statement + !======================================================== + recursive subroutine trav_over_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,stmt,namelist,rtns,stmtlist + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: base,xtop,vbase + type(pm_ptr):: keynames,keys + + if(coder%par_state==par_state_none) then + call code_error(coder,node,& + 'Cannot have an "over" statement outside of a parallel context') + elseif(coder%par_state>=par_state_masked) then + call code_error(coder,node,& + 'Cannot have an "over" statement inside a conditional statement') + endif + + keys=node_arg(node,2) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) + endif + + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC + endif + + call trav_expr(coder,cblock,node,node_arg(node,1)) + vbase=coder%vtop + + if(base>=0) call hide_vars(coder,base+1,xtop) + + call make_block_proc(coder,cblock,node,& + pm_null_obj,& + int(coder%comm_amp%offset),pm_null_obj,0,& + node_arg(node,4)) + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + call code_val(coder,coder%vstack(vbase)) + call make_full_sys_call(coder,cblock,node,sym_pm_over_stmt,4,0,& + coder%block_amp,keys,keynames,& + proccall_is_comm+proccall_is_general) + call drop_code(coder) + coder%temp2=pm_null_obj + contains + include 'fisnull.inc' + end subroutine trav_over_stmt + + !================================================================================= + ! Create code to create up to three lists of values + ! derived from expressions in an iterator node: + ! [ amp_values ] values [ star_values ] + ! relating to &x in Y, x in Y and *x in Y iterator entries respectively + ! + ! Also codes any necessary alias checks between "&" items and other items + !================================================================================== + subroutine make_iter_lists(coder,cblock,node,n,may_have_amp,may_have_star) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: n + logical,intent(in):: may_have_amp,may_have_star + type(pm_ptr):: arg,arg2 + integer:: i,j,k,kind,m,sym,name,base,base2,nalias + + base=coder%vtop + + ! Check for any potential aliases + if(may_have_amp) then + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_amp) then + arg=node_arg(node,i+1) + name=node_num_arg(arg,1) + kind=node_sym(arg) + do j=1,n,2 + if(j/=i) then + arg2=node_arg(node,j+1) + k=node_sym(arg2) + if(k==sym_name.or.k==sym_reference) then + call check_alias(coder,cblock,arg,arg2,& + '"&" item aliases with another item') + endif + endif + enddo + endif + enddo + endif + + ! Now evaluate each value + if(may_have_amp) then + do i=1,n,2 + arg=node_arg(node,i+1) + k=node_sym(arg) + if(k==sym_name.or.k==sym_reference) then + call trav_ref(coder,cblock,node,arg,& + node_sym(node_arg(node,i))/=sym_amp,& + call_sym=sym_iter_ref) + else + call trav_expr(coder,cblock,node,node_arg(node,i+1)) + endif + enddo + else + do i=1,n,2 + call trav_expr(coder,cblock,node,node_arg(node,i+1)) + enddo + endif + + ! Create conformity checks + call dup_expr(coder,coder%vstack(base+1)) + call make_sys_call(coder,cblock,node,check_fn(node_arg(node,1)),1,0) + do i=2,n/2 + call dup_expr(coder,coder%vstack(base+i)) + call dup_expr(coder,coder%vstack(base+1)) + call make_sys_call(coder,cblock,node,check_fn(node_arg(node,i*2-1)),2,0) + enddo + + ! Finally create the lists + base2=coder%vtop + + if(may_have_amp) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) + m=0 + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_amp) then + call code_val(coder,coder%vstack(base+(i+1)/2)) + m=m+1 + endif + enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,m,1) + endif + call make_temp_var(coder,cblock,node) + call dup_code(coder) + m=0 + do i=1,n,2 + sym=node_sym(node_arg(node,i)) + if(sym/=sym_amp.and.sym/=sym_mult) then + call code_val(coder,coder%vstack(base+(i+1)/2)) + m=m+1 + endif + enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,m,1) + if(may_have_star) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) + m=0 + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_mult) then + call code_val(coder,coder%vstack(base+(i+1)/2)) + m=m+1 + endif + enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,m,1) + endif + + ! Copy lists back down + j=coder%vtop + coder%vtop=base + do i=base2+1,j + coder%vtop=coder%vtop+1 + coder%vstack(coder%vtop)=coder%vstack(i) + enddo + + contains + + function check_fn(node) result(fn) + type(pm_ptr),intent(in):: node + integer:: fn + integer:: k + k=node_sym(node) + if(k==sym_amp) then + fn=sym_check_iter_amp + elseif(k==sym_mult) then + fn=sym_check_iter_star + else + fn=sym_check_iter + endif + end function check_fn + + end subroutine make_iter_lists + + !============================================================================ + ! Create code to extract variables defined by iter node (node) from named + ! list variable PM__amp_iter_args, PM__iter_args and PM__star iter args as + ! appropriate depending on whether iter entry is &x in Y, x in Y or *x in Y + !=========================================================================== + subroutine extract_iter_lists(coder,cblock,node,may_have_amp,may_have_star) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + logical,intent(in):: may_have_amp,may_have_star + integer:: i,m,n,sym + type(pm_ptr)::p,avar + n=node_numargs(node) + if(may_have_amp) then + avar=find_sys_var(coder,node,sym_amp_iter_args) + m=1 + do i=1,n,2 + p=node_arg(node,i) + if(node_sym(p)==sym_amp) then + call make_var(coder,cblock,node,node_num_arg(p,1),var_is_var+var_is_ref) + call extract_var(coder,cblock,node,pop_code(coder),avar,m) + m=m+1 + endif + enddo + endif + avar=find_sys_var(coder,node,sym_iter_args) + m=1 + do i=1,n,2 + p=node_arg(node,i) + sym=node_sym(p) + if(sym/=sym_amp.and.sym/=sym_mult) then + call make_var(coder,cblock,node,int(p%offset),0) + call extract_var(coder,cblock,node,pop_code(coder),avar,m) + m=m+1 + endif + enddo + if(may_have_star) then + avar=find_sys_var(coder,node,sym_star_iter_args) + m=1 + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_mult) then + call make_var(coder,cblock,node,node_num_arg(p,1),0) + call extract_var(coder,cblock,node,pop_code(coder),avar,m) + m=m+1 + endif + enddo + endif + end subroutine extract_iter_lists + + !====================================================================================== + ! Turns a block (stmtlist) into a procedure + ! Pushes 3 elements onto vstack + ! procedure value defining block + ! list of changed variables + ! list of accessed variables + ! Parameter list for block procedure starts with + ! PM__inouts_a PM__ins_a + ! - code is added to the start of the procedure body to disaggregate these + ! parameters from lists back into changed and accessed variables respectively + ! If iters is not present + ! - The remaining block-procedure parameters are defined by (namelist,amps) + ! If iters is present + ! -the remaining block-procedure parameters are + ! [ & PM__amp_iter_args ] PM__iter_args [ PM__star_iter_args ] + ! and namelist (but not amps) is disregarded + ! Extra disaggregation code for iter parameters is added inside the block + !====================================================================================== + subroutine make_block_proc(coder,cblock,node,namelist,amps,rtns,nret,stmtlist,iters,iter_amps,iter_stars) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,namelist,rtns,stmtlist integer,intent(in):: amps,nret + type(pm_ptr),intent(in),optional:: iters + logical,intent(in),optional:: iter_amps,iter_stars type(pm_ptr):: cblock2,cblock3,proc - integer:: nargs,base,i,partype,restype,flags + integer:: nargs,base,i,partype,restype,flags,vbase logical:: varargs - integer:: name,save_index,save_ncalls - integer:: signo,args(1) - character(len=12):: namestr - - write(*,*) 'START--->',coder%wtop,coder%vtop + integer:: save_index,save_ncalls,save_state_base,save_mask + integer:: name,signo,flags0,args(1) + character(len=15):: namestr + + if(present(iters)) then + nargs=1+merge(1,0,iter_amps)+merge(1,0,iter_stars) + else + nargs=node_numargs(namelist) + endif - nargs=node_numargs(namelist) varargs=node_sym(namelist)==sym_dotdotdot flags=proccall_is_comm+proccall_is_general @@ -985,9 +1615,7 @@ subroutine make_block_proc(coder,cblock,stmt,namelist,amps,rtns,nret,stmtlist) namestr='PM__block'//trim(pm_int_as_string(coder%block_id)) name=pm_name2(coder%context,sym_block,pm_name_entry(coder%context,namestr)) - write(*,*) 'REGAIN--->',coder%wtop,coder%vtop - - call make_sys_var(coder,cblock,stmt,sym_block_proc_a,var_is_shadowed) + call make_sys_var(coder,cblock,node,sym_block_proc_a,var_is_shadowed) ! Create proc object call code_num(coder,partype) @@ -1008,13 +1636,11 @@ subroutine make_block_proc(coder,cblock,stmt,namelist,amps,rtns,nret,stmtlist) call code_null(coder) call code_null(coder) call code_null(coder) - call make_code(coder,stmt,cnode_is_proc,pr_node_size) + call make_code(coder,node,cnode_is_proc,pr_node_size) proc=top_code(coder) - - write(*,*) 'AGAIN--->',coder%wtop,coder%vtop - + ! Create one-element signature - call make_code(coder,stmt,cnode_is_callsig,1) + call make_code(coder,node,cnode_is_callsig,1) args(1)=name signo=pm_idict_add(coder%context,coder%sig_cache,& @@ -1029,14 +1655,10 @@ subroutine make_block_proc(coder,cblock,stmt,namelist,amps,rtns,nret,stmtlist) call push_word(coder,restype) call make_type(coder,4) call make_type(coder,3) - - write(*,*) 'proctyp=',trim(pm_type_as_string(coder%context,top_word(coder))) - - call make_const(coder,cblock,stmt,& + + call make_const(coder,cblock,node,& pm_fast_name(coder%context,name),pop_word(coder)) - call make_sys_call(coder,cblock,stmt,sym_dup,1,1) - - + call make_sys_call(coder,cblock,node,sym_clone,1,1) save_index=coder%index save_ncalls=coder%proc_ncalls coder%index=0 @@ -1044,79 +1666,90 @@ subroutine make_block_proc(coder,cblock,stmt,namelist,amps,rtns,nret,stmtlist) call push_block_scope(coder,cblock2) - write(*,*) 'MARZ' - do i=1,coder%top - write(*,*) pm_name_as_string(coder%context,coder%stack(i)) - enddo - write(*,*) '---end---' - base=coder%top + vbase=coder%vtop + + save_state_base=coder%state_base + save_mask=coder%mask + coder%state_base=coder%top ! Create state variable parameters - call make_sys_var(coder,cblock2,stmt,sym_topology,var_is_param+var_is_shadowed) - call make_sys_var(coder,cblock2,stmt,sym_outer,var_is_param+var_is_shadowed) - call make_sys_var(coder,cblock2,stmt,sym_region,var_is_param+var_is_shadowed) - call make_sys_var(coder,cblock2,stmt,sym_subregion,var_is_param+var_is_shadowed) - call make_sys_var(coder,cblock2,stmt,sym_here_in_tile,& + call make_sys_var(coder,cblock2,node,sym_topology,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_outer,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_region,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_subregion,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_here_in_tile,& var_is_param+var_is_shadowed) - call make_sys_var(coder,cblock2,stmt,sym_mask,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_mask,var_is_param+var_is_shadowed) ! Create variables for block imports and exports - call make_sys_var(coder,cblock2,stmt,& - sym_block_inouts,var_is_param+var_is_ref+var_is_var) - call make_sys_var(coder,cblock2,stmt,& - sym_block_ins,var_is_param) + call make_sys_var(coder,cblock2,node,& + sym_block_inouts,var_is_param+var_is_ref+var_is_var+var_is_shadowed) + call make_sys_var(coder,cblock2,node,& + sym_block_ins,var_is_param+var_is_shadowed) ! Remaining parameter variables - call trav_params(coder,cblock2,namelist,amps,1,8) - - write(*,*) 'THEN--->',coder%wtop,coder%vtop - + if(present(iters)) then + flags0=var_is_maybe_not_private + if(iter_amps) then + call make_sys_var(coder,cblock2,node,& + sym_amp_iter_args,flags0+var_is_param+var_is_ref+var_is_var+var_is_shadowed) + endif + call make_sys_var(coder,cblock2,node,& + sym_iter_args,flags0+var_is_param+var_is_shadowed) + if(iter_stars) then + call make_sys_var(coder,cblock2,node,& + sym_star_iter_args,flags0+var_is_param+var_is_shadowed) + endif + call make_basic_sp_call(coder,cblock2,node,& + sym_open,coder%vtop-vbase,0) + else + call trav_params(coder,cblock2,namelist,amps,1,8) + endif + call code_val(coder,coder%var(base+4)) cblock3=make_cblock(coder,cblock2,stmtlist,sym_do_stmt) coder%lex_scope=coder%lex_scope+1 + if(present(iters)) then + call extract_iter_lists(coder,cblock3,iters,iter_amps,iter_stars) + endif - call trav_open_stmt_list(coder,cblock3,stmt,stmtlist) + call trav_open_stmt_list(coder,cblock3,node,stmtlist) - call trav_xexpr(coder,cblock3,stmt,rtns) + call trav_xexpr(coder,cblock3,node,rtns) + call make_sp_call(coder,cblock3,node,sym_result,nret,0) coder%lex_scope=coder%lex_scope-1 call close_cblock(coder,cblock3) - - write(*,*) 'CARZ' - do i=1,coder%top - write(*,*) pm_name_as_string(coder%context,coder%stack(i)) - enddo - write(*,*) '---end---' - call extract_block_vars(coder,cblock2,stmt,coder%var(base+7),.true.) - call extract_block_vars(coder,cblock2,stmt,coder%var(base+8),.false.) - call make_sp_call(coder,cblock2,stmt,sym_do,1,0) + call extract_block_vars(coder,cblock2,node,coder%var(base+7),.true.) + call extract_block_vars(coder,cblock2,node,coder%var(base+8),.false.) + + call make_sp_call(coder,cblock2,node,sym_pct,2,0) + call cnode_set_num(proc,pr_max_index,coder%index) call cnode_set_num(proc,pr_ncalls,coder%proc_ncalls) coder%index=save_index coder%proc_ncalls=save_ncalls + coder%state_base=save_state_base + coder%mask=save_mask - write(*,*) 'AFTA--->',coder%wtop,coder%vtop call close_cblock(coder,cblock2) - - write(*,*) 'VARZ' - do i=1,coder%top - write(*,*) pm_name_as_string(coder%context,coder%stack(i)) - enddo - write(*,*) '---end---' - - call pop_block_scope(coder,cblock,stmt) - - - - write(*,*) 'FINALLY--->',coder%wtop,coder%vtop + + ! This also pushes lists of changed and accessed variables + call pop_block_scope(coder,cblock,node,present(iters)) contains include 'fisnull.inc' include 'fname.inc' end subroutine make_block_proc + !=============================================================== + ! Create code to disaggregate variables from list variable avar + ! Variables are obtained from the access/change list + ! for current block scope and only included if their change + ! status (modified=> true) is equal to access + !=============================================================== subroutine extract_block_vars(coder,cblock,node,avar,access) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,avar @@ -1132,40 +1765,18 @@ subroutine extract_block_vars(coder,cblock,node,avar,access) index=p%data%ptr(p%offset)%offset var=coder%var(index) if(iand(cnode_get_num(var,var_flags),var_is_changed)/=0.eqv.access) then - call extract_var(coder,cblock,node,coder%var(index),avar,i) - i=i+1 - endif - p=p%data%ptr(p%offset+1) - enddo - contains - include 'fisnull.inc' - end subroutine extract_block_vars - - subroutine push_block_vars(coder,list,access,n) - type(code_state),intent(inout):: coder - logical,intent(in):: access - type(pm_ptr),intent(in):: list - integer,intent(out):: n - - type(pm_ptr):: p,var - integer:: index,i - - p=list - i=0 - do while(.not.pm_fast_isnull(p)) - index=p%data%ptr(p%offset)%offset - var=coder%var(index) - if(iand(cnode_get_num(var,var_flags),var_is_changed)/=0.eqv.access) then - call code_val(coder,var) + call extract_var(coder,cblock,node,coder%var(index),avar,i) i=i+1 endif p=p%data%ptr(p%offset+1) enddo - n=i contains include 'fisnull.inc' - end subroutine push_block_vars - + end subroutine extract_block_vars + + !=========================================================== + ! Make code to extract index'th element of list avar to var + !=========================================================== subroutine extract_var(coder,cblock,node,var,avar,index) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,var,avar @@ -1175,9 +1786,12 @@ subroutine extract_var(coder,cblock,node,var,avar,index) call code_val(coder,avar) call make_long_const(coder,cblock,node,int(index,pm_ln)) call make_comm_sys_call(coder,cblock,node,sym_elem_at_index,2,1,& - aflags=proccall_is_ref,assign=.true.) + aflags=proccall_is_ref+proccall_is_general,assign=.true.) end subroutine extract_var + !======================================================== + ! Push a new block scope record onto wstack and vstack + !======================================================== subroutine push_block_scope(coder,cblock) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock @@ -1193,12 +1807,65 @@ subroutine push_block_scope(coder,cblock) coder%block_entry=base end subroutine push_block_scope - subroutine pop_block_scope(coder,cblock,node) + ! ================================================================ + ! Import a variable into a block scope + ! - creates new variable linked to the old one + ! - change local symbol table to point to new variable + ! ================================================================ + recursive subroutine import_to_block_scope(coder,index,var,block_entry) + type(code_state),intent(inout):: coder + integer,intent(in):: index,block_entry + type(pm_ptr),intent(inout):: var + integer:: var_scope,block_scope,block_links + if(debug_more_codegen) then + write(*,*) 'import_to_block_scope',block_entry,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) + endif + if(block_entry==0) return + var_scope=cnode_get_num(var,var_lex_scope) + block_scope=coder%wstack(block_entry+2) + block_links=coder%wstack(block_entry+3) + if(var_scope>=block_scope) return + call make_var(coder,& + coder%vstack(block_links+1),& + pm_null_obj,& + cnode_get_num(var,var_name),& + ior(cnode_get_num(var,var_flags),var_is_imported),& + extra_info=var) + var=pop_code(coder) + call cnode_set_num(var,var_lex_scope,coder%wstack(block_entry+2)) + if(debug_more_codegen) then + write(*,*) 'lex scope now',coder%wstack(block_entry+2) + write(*,*) 'index now',cnode_get_num(var,var_index) + endif + call add_to_change_list(coder,coder%vstack(block_links),& + pm_fast_tinyint(coder%context,index)) + contains + include 'fisnull.inc' + include 'ftiny.inc' + end subroutine import_to_block_scope + + ! ====================================================== + ! Pop block scope from top of wstack & vstack + ! - pop any imported variables back to their originals + ! via their link + ! + ! Push two list values onto vstack for variables + ! respectively changed and accessed in the block + ! + ! Also check for aliasing with call arguments/iterator + ! (call or iterator must be passed as node) + ! ====================================================== + subroutine pop_block_scope(coder,cblock,node,iter) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node + logical,intent(in):: iter type(pm_ptr):: list type(pm_ptr)::p,var - integer:: index,nwrites,nreads + integer:: index,nwrites,nreads,base + logical:: changed + + ! Check we are aligned with block scope records on vstack and wstack if(pm_debug_checks) then if(coder%wtop/=coder%block_entry+3) then call pm_panic("pop_block_scope: wstack") @@ -1207,104 +1874,344 @@ subroutine pop_block_scope(coder,cblock,node) call pm_panic("pop_block_scope: vstack") endif endif + + ! Pop the block scope record from wstack and vstack list=coder%vstack(coder%vtop-1) - coder%temp2=list + coder%temp2=list ! Protect list from the gc coder%block_entry=coder%wstack(coder%block_entry) coder%block_base=coder%wstack(coder%block_entry+1) coder%vtop=coder%vtop-2 coder%wtop=coder%wtop-4 + + base=coder%wtop + + ! Now pop each variable + p=list + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + changed=cnode_flags_set(var,var_flags,var_is_changed) + var=cnode_get(var,var_extra_info) + ! May need to re-import into current scope + call import_to_block_scope(coder,index,var,coder%block_entry) + call access_var(coder,var,changed) + coder%var(index)=var + ! Flag changed variables with a -ve index + if(changed) p%data%ptr(p%offset)%offset=-index + p=p%data%ptr(p%offset+1) + enddo + + ! Create list of all changed variables p=list nwrites=0 call make_sys_var(coder,cblock,node,sym_block_inouts_a,& var_is_shadowed+var_is_var+var_is_ref) do while(.not.pm_fast_isnull(p)) index=p%data%ptr(p%offset)%offset - var=coder%var(index) - if(cnode_flags_set(var,var_flags,var_is_changed)) then - call code_val(coder,cnode_get(var,var_extra_info)) + ! Changed variables have -ve index + if(index<0) then + call code_val(coder,coder%var(-index)) + call push_word(coder,cnode_get_num(coder%var(-index),var_name)) nwrites=nwrites+1 endif p=p%data%ptr(p%offset+1) enddo - if(nwrites>0) then - call make_sp_call(coder,cblock,node,sym_open_smiley,nwrites,1) - else - call make_sp_call(coder,cblock,node,sym_null,0,1) - endif + call make_basic_sp_call(coder,cblock,node,sym_pm_list,nwrites,1) + + ! Create a list of all accessed variables p=list nreads=0 - call make_sys_var(coder,cblock,node,sym_block_ins_a,var_is_shadowed) + call make_sys_var(coder,cblock,node,sym_block_ins_a,& + var_is_shadowed+var_is_var) do while(.not.pm_fast_isnull(p)) index=p%data%ptr(p%offset)%offset - var=coder%var(index) - write(*,*) 'REAd',& - trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) - if(cnode_flags_clear(var,var_flags,var_is_changed)) then - var=cnode_get(coder%var(index),var_extra_info) - call code_val(coder,var) + ! Unchanged (but accessed) variables have a +ve index + if(index>0) then + call code_val(coder,coder%var(index)) + call push_word(coder,cnode_get_num(coder%var(index),var_name)) nreads=nreads+1 - else - var=cnode_get(coder%var(index),var_extra_info) endif - coder%var(index)=var p=p%data%ptr(p%offset+1) enddo - if(nreads>0) then - call make_sp_call(coder,cblock,node,sym_open_smiley,nreads,1) + call make_basic_sp_call(coder,cblock,node,sym_pm_list,nreads,1) + + ! Check for alias with iter or argument list + if(.not.iter) then + call check_call_block_alias(coder,cblock,node,base,nreads,nwrites) else - call make_sp_call(coder,cblock,node,sym_null,0,1) + call check_iter_block_alias(coder,cblock,node,base,nreads,nwrites) endif + + ! Clean up + coder%wtop=base coder%temp2=pm_null_obj contains include 'fisnull.inc' end subroutine pop_block_scope - recursive subroutine import_to_block_scope(coder,index,var,block_entry) + !=================================================================== + ! Check variables used as arguments to call to those + ! accessed/modified by block (whose names must be pushed on wstack) + ! above base (nwrites writes followed by nreads reads) + !=================================================================== + subroutine check_call_block_alias(coder,cblock,node,base,nreads,nwrites) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: base,nreads,nwrites + type(pm_ptr):: args,amp,arg + integer:: i,j,k,name,sym + args=node_arg(node,2) + amp=pm_name_val(coder%context,node_num_arg(node,3)) + if(pm_fast_isnull(amp)) then + do i=1,node_numargs(args) + arg=node_arg(args,i) + sym=node_sym(arg) + if(sym==sym_reference.or.sym==sym_name) then + name=root_name(arg) + do j=1,nwrites + if(coder%wstack(base+i)==name) then + call code_error(coder,arg,& + 'Variable is modified by the block that is also used by an argument: ',& + node_num_arg(arg,1)) + endif + enddo + endif + enddo + else + k=0 + do i=1,node_numargs(args) + arg=node_arg(args,i) + if(amp%data%i(amp%offset+k)==i) then + name=node_num_arg(arg,1) + do j=1,nwrites+nreads + if(coder%wstack(base+i)==name) then + if(j<=nwrites) then + call code_error(coder,arg,& + 'Variable is modified by the block that is also modified as an argument: ',& + node_num_arg(arg,1)) + else + call code_error(coder,arg,& + 'Variable is accessed by the block that is also modified as an argument: ',& + node_num_arg(arg,1)) + endif + endif + enddo + k=min(k+1,pm_fast_esize(amp)) + else + if(node_sym(arg)==sym_amp) then + name=node_num_arg(arg,1) + do j=1,nwrites + if(coder%wstack(base+i)==name) then + call code_error(coder,arg,& + 'Variable is modified by the block that is also used by an argument: ',& + node_num_arg(arg,1)) + endif + enddo + endif + endif + enddo + endif + contains + include 'fisnull.inc' + include 'fesize.inc' + end subroutine check_call_block_alias + + + !=================================================================== + ! Check variables defined in iterator against variables + ! accessed/modified by block (whose names must be pushed on wstack) + ! above base (nwrites writes followed by nreads reads) + !=================================================================== + subroutine check_iter_block_alias(coder,cblock,node,base,nreads,nwrites) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: base,nreads,nwrites + integer:: i,j,name,sym + type(pm_ptr):: arg + do i=1,node_numargs(node),2 + arg=node_arg(node,i+1) + sym=node_sym(arg) + if(sym==sym_name.or.sym==sym_reference) then + name=root_name(arg) + do j=1,merge(nwrites+nreads,nreads,node_sym(node_arg(node,i))==sym_amp) + if(coder%wstack(base+j)==name) then + if(j<=nwrites) then + call code_error(coder,arg,'Block modifies variable that is used by iterator: ',& + node_num_arg(arg,1)) + else + call code_error(coder,arg,'Block uses variable which is modified by iterator: ',& + node_num_arg(arg,1)) + endif + endif + enddo + endif + enddo + end subroutine check_iter_block_alias + + function root_name(arg) result(name) + type(pm_ptr),intent(in):: arg + integer:: name + integer:: sym + sym=node_sym(arg) + if(sym==sym_name) then + name=node_num_arg(arg,1) + else !! reference + name=node_num_arg(node_arg(arg,1),1) + endif + end function root_name + + + !================================================ + ! Create a new lexical scope (used to identify + ! variables defined outside the statement that + ! are accessed or modified within it) + ! Pushes small record on vstack + !================================================ + function push_lex_scope(coder) result(new_lex_scope) + type(code_state),intent(inout):: coder + integer:: new_lex_scope + call code_num(coder,coder%lex_scope) + call code_null(coder) + call code_null(coder) + new_lex_scope=coder%vtop + end function push_lex_scope + + !=========================================== + ! Push change lists of current lexical scope + ! as a changelist cnode + !=========================================== + subroutine get_lex_scope(coder,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + call code_val(coder,coder%vstack(coder%lex_scope)) + call code_val(coder,coder%vstack(coder%lex_scope-1)) + call make_code(coder,node,cnode_is_changelist,2) + end subroutine get_lex_scope + + !=================================== + ! Exit lexical scope + ! Pops record off the top of vstack + !=================================== + subroutine pop_lex_scope(coder) + type(code_state),intent(inout):: coder + coder%lex_scope=coder%vstack(coder%vtop-2)%offset + call drop_code(coder) + call drop_code(coder) + call drop_code(coder) + end subroutine pop_lex_scope + + !========================================== + ! Record read or write (if modify is true) + ! access to a variable + !=========================================== + subroutine access_var(coder,var,modify) type(code_state),intent(inout):: coder - integer,intent(in):: index,block_entry type(pm_ptr),intent(inout):: var - integer:: var_scope,block_scope,block_links - write(*,*) 'import_to_block_scope',block_entry,& - trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) - if(block_entry==0) return - var_scope=cnode_get_num(var,var_lex_scope) - block_scope=coder%wstack(block_entry+2) - block_links=coder%wstack(block_entry+3) - write(*,*) 'with',var_scope,block_scope,block_entry - if(var_scope>=block_scope) return - write(*,*) 'recursing with',coder%wstack(block_entry) - call import_to_block_scope(coder,index,var,coder%wstack(block_entry)) - call make_var(coder,& - coder%vstack(block_links+1),& - pm_null_obj,& - cnode_get(var,var_name),& - ior(cnode_get_num(var,var_flags),var_is_imported),& - extra_info=var) - var=pop_code(coder) - call cnode_set_num(var,var_lex_scope,coder%wstack(block_entry+2)) - write(*,*) 'lex scope now',coder%wstack(block_entry+2) - write(*,*) 'index now',cnode_get_num(var,var_index) - call add_to_change_list(coder,coder%vstack(block_links),& - pm_fast_tinyint(coder%context,index)) - write(*,*) 'pushing block var',index - call qdump_code_tree(coder,pm_null_obj,6,var,2) - coder%var(index)=var + logical,intent(in):: modify + if(debug_more_codegen) then + if(coder%block_base>0) write(*,*) 'access var',modify,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))),& + cnode_get_num(var,var_index) + endif + if(modify) then + call cnode_set_flags(var,var_flags,var_is_changed) + else + if(cnode_flags_set(var,var_flags,var_is_accessed)) then + call cnode_set_flags(var,var_flags,var_is_multi_access) + else + call cnode_set_flags(var,var_flags,var_is_accessed) + endif + endif + call update_change_lists(coder,var,modify) + end subroutine access_var + + !============================================= + ! Add var to the change list for all if scopes + ! that are nested inside the scope in which + ! the variable was defined + !============================================= + subroutine update_change_lists(coder,var,modify) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: var + logical,intent(in):: modify + integer:: lex_scope,lex_scope_of_var + lex_scope=coder%lex_scope + lex_scope_of_var=cnode_get_num(var,var_lex_scope) + do while(var_lex_scope=0) call hide_vars(coder,base+1,xtop) + end subroutine trav_xexpr + !============================================================== ! Traverse extended expression: expr [check expr] { where ...} !============================================================== - recursive subroutine trav_xexpr(coder,cblock,exprp,exprn,stmt) + recursive subroutine trav_subexpr(coder,cblock,exprp,exprn,base,top) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,exprp,exprn - type(pm_ptr),intent(in),optional:: stmt + integer,intent(out):: base,top type(pm_ptr)::p,ass - integer:: i,j,base,top + integer:: i p=exprn + base=-1 + top=-2 + if(pm_fast_isnull(p)) return if(node_sym(p)==sym_where) then base=coder%top do @@ -1316,8 +2223,18 @@ recursive subroutine trav_xexpr(coder,cblock,exprp,exprn,stmt) if(node_sym(p)/=sym_where) exit enddo top=coder%top - else - base=-1 + endif + if(node_sym(p)==sym_distinct) then + do + do i=2,node_numargs(p),2 + call trav_comm_ref(coder,cblock,p,node_arg(p,i+1),.true.,.true.) + call dup_expr(coder,top_code(coder)) + call make_sys_call_rtn(coder,cblock,p,sym_get_val_ref,1,1) + enddo + call make_sys_call(coder,cblock,p,sym_check_alias,node_numargs(p)/2,0) + p=node_arg(p,1) + if(node_sym(p)/=sym_distinct) exit + enddo endif if(node_sym(p)==sym_check) then call apply_x(p,node_arg(p,1)) @@ -1325,52 +2242,40 @@ recursive subroutine trav_xexpr(coder,cblock,exprp,exprn,stmt) else call apply_x(exprp,p) endif - if(base>=0) call hide_vars(coder,base+1,top) contains include 'fisnull.inc' include 'fisname.inc' include 'fname.inc' include 'ftiny.inc' - subroutine apply_x(nodep,node) + recursive subroutine apply_x(nodep,node) type(pm_ptr),intent(in):: nodep,node type(pm_ptr):: nodei - integer:: wbase,i,flags,numret - logical:: outer - + integer:: wbase,i,nsym wbase=coder%wtop if(pm_fast_isnull(node)) return select case(node_sym(node)) case(sym_assign) call trav_assign_define(coder,cblock,nodep,node) - case(sym_case) - do i=1,node_numargs(node) - nodei=node_arg(node,i) - if(node_sym(nodei)==sym_dotdot) then - call trav_expr(coder,cblock,node,node_arg(nodei,1)) - call trav_expr(coder,cblock,node,node_arg(nodei,2)) - call make_sys_call_rtn(coder,cblock,node,sym_case_range,2,1) - else - call trav_expr(coder,cblock,node,nodei) - endif - enddo case(sym_assign_list) call trav_assign_define_list(coder,cblock,nodep,node) - case(sym_sync_assign) - call trav_sync_assign(coder,cblock,nodep,node) - case(sym_iter) - if(node_sym(stmt)==sym_for) then -! call trav_for_stmt(coder,cblock,nodep,node,base,stmt) - else - call trav_foreach_stmt(coder,cblock,nodep,node,base,stmt) - endif case(sym_list) call trav_exprlist(coder,cblock,nodep,node) case(sym_result) call push_word(coder,pm_type_is_tuple) call push_word(coder,0) do i=1,node_numargs(node),2 - call trav_expr(coder,cblock,node,node_arg(node,i)) + nodei=node_arg(node,i) + call trav_expr(coder,cblock,node,nodei) + nsym=node_sym(nodei) + if(nsym==sym_name.or.nsym==sym_reference) then + nodei=find_var(coder,root_name(nodei)) + if(.not.pm_fast_isnull(nodei)) then + if(cnode_flags_set(nodei,var_flags,var_is_param)) then + call make_sys_call_rtn(coder,cblock,node,sym_clone,1,1) + endif + endif + endif nodei=node_arg(node,i+1) if(.not.pm_fast_isnull(nodei)) then call trav_cast(coder,cblock,node,nodei,sym_const) @@ -1397,8 +2302,7 @@ subroutine apply_x(nodep,node) endif end subroutine apply_x - end subroutine trav_xexpr - + end subroutine trav_subexpr !======================================================== ! Compile check @@ -1429,525 +2333,34 @@ recursive subroutine make_check(coder,cblock,p,base) cblock3=make_cblock(coder,cblock,p,sym_check) call trav_expr(coder,cblock3,p,node_arg(p,i+1)) call init_var(coder,cblock3,p,coder%vstack(coder%vtop-2)) - call close_cblock(coder,cblock3) - call make_sp_call(coder,cblock,p,sym_check,4,0) - end do - contains - include 'fisnull.inc' - end subroutine make_check - - !======================================================== - ! switch statement - cases and otherwise clause - ! assumes expression is in var - !======================================================== - recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock - type(pm_ptr),intent(in):: stmt,var - integer,intent(in):: idx,sym - type(pm_ptr):: cblock2 - integer:: base,save_par_state,n,i,j,lex_scope - lex_scope=push_lex_scope(coder) - base=coder%vtop - - call trav_xexpr(coder,cblock,stmt,node_arg(stmt,idx)) - n=coder%vtop-base - do i=1,n - call code_val(coder,var) - call code_val(coder,coder%vstack(base+i)) - call make_sys_call_rtn(coder,cblock,stmt,& - sym_checkcase,2,1) - if(i>1) then - call make_sys_call_rtn(coder,cblock,stmt,& - sym_or,2,1) - endif - enddo - coder%vstack(base+1)=top_code(coder) - coder%vtop=base+1 - if(sym==sym_if_invar) then - call code_check_invar(coder,cblock,stmt,top_code(coder)) - endif - coder%lex_scope=lex_scope - call trav_stmt_list(coder,cblock,stmt,& - node_arg(stmt,idx+1),sym_switch) - if(idx==node_numargs(stmt)-2) then - if(pm_fast_isnull(node_arg(stmt,idx+2))) then - call code_null(coder) - else - call trav_stmt_list(coder,cblock,stmt,& - node_arg(stmt,idx+2),sym_switch) - endif - else - cblock2=make_cblock(coder,cblock,stmt,sym_switch) - call trav_switch_stmt(coder,cblock2,stmt,idx+2,var,sym) - call close_cblock(coder,cblock2) - endif - call get_lex_scope(coder,stmt) - call make_sp_call(coder,cblock,stmt,sym,4,0) - call pop_lex_scope(coder) - contains - include 'fisnull.inc' - end subroutine trav_switch_stmt - - !======================================================== - ! Traverse statement qualified by a mode - !======================================================== - recursive subroutine trav_mode_stmt(coder,cblock,node,nsym,isexpr) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: nsym - logical,intent(in):: isexpr - integer:: sym,save_run_mode,save_run_flags,save_par_state -!!$ sym=node_num_arg(node,2) -!!$ if(coder%par_state==par_state_outer) then -!!$ call code_error(coder,node,'Cannot have "'//& -!!$ trim(sym_names(sym))//& -!!$ '" statement outside of a parallel context') -!!$ elseif(coder%par_state==par_state_nhd) then -!!$ call code_error(coder,node,'Cannot have "'//& -!!$ trim(sym_names(sym))//& -!!$ '" statement in main body of "nhd" statement') -!!$ endif -!!$ -!!$ save_run_mode=coder%run_mode -!!$ save_run_flags=coder%run_flags -!!$ coder%run_mode=sym -!!$ select case(sym) -!!$ case(sym_coherent:sym_invar) -!!$ coder%run_flags=proc_run_complete+proc_run_always -!!$ case(sym_shared) -!!$ coder%run_flags=proc_run_shared+proc_run_always -!!$ end select -!!$ if(isexpr) then -!!$ call trav_expr(coder,cblock,node,node_arg(node,1)) -!!$ else -!!$ call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) -!!$ endif -!!$ coder%run_mode=save_run_mode -!!$ coder%run_flags=save_run_flags - end subroutine trav_mode_stmt - - !======================================================== - ! Traverse "any" statement - !======================================================== - recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer,intent(in):: sym - integer:: k,i,j,n,flags,start,finish,vb,lex_scope - type(pm_ptr):: cblock2,vlist,v,var - integer:: save_par_state - - lex_scope=push_lex_scope(coder) - - if(pm_fast_isnull(node_arg(node,2))) then - flags=var_is_shadowed+var_is_var - call trav_expr(coder,cblock,node,node_arg(node,1)) - else - flags=var_is_var - call trav_xexpr(coder,cblock,node,node_arg(node,2)) - endif - v=top_code(coder) - save_par_state=coder%par_state - if(sym==sym_any) then - coder%par_state=par_state_any - else - call code_check_invar(coder,cblock,node,v) - endif - cblock2=make_cblock(coder,cblock,node,sym_any) - call make_var(coder,cblock,node,node_arg(node_arg(node,1),1),flags) - vb=coder%top - var=top_code(coder) - start=coder%index - call swap_code(coder) - coder%lex_scope=lex_scope - call trav_open_stmt_list(coder,cblock2,node,node_arg(node,3)) - if(cnode_flags_set(var,var_flags,var_is_changed)) then - call code_val(coder,var) - call dup_expr(coder,v) - call make_sys_call_rtn(coder,cblock2,node,sym_as,2,1) - call hide_vars(coder,vb,vb) - if(pm_fast_isnull(node_arg(node,2))) then - call make_assignment_noalias(coder,cblock2,node,node_arg(node,1)) - else - call make_assignment_noalias(coder,cblock2,node,node_arg(node,2)) - endif - call reveal_vars(coder,vb,vb) - endif - finish=coder%index - call close_cblock(coder,cblock2) - call code_val(coder,v) - v=pm_fast_newnc(coder%context,pm_int,2) - coder%temp2=v - v%data%i(v%offset)=start - v%data%i(v%offset+1)=finish - call make_const(coder,cblock,node,coder%temp2) - call get_lex_scope(coder,node) - call make_sp_call(coder,cblock,node,sym_any,4,1) - call drop_code(coder) - call hide_vars(coder,vb,vb) - call pop_lex_scope(coder) - coder%par_state=save_par_state - contains - include 'fisnull.inc' - include 'fnewnc.inc' - end subroutine trav_any_stmt - - !======================================================== - ! Traverse a for each statement - ! -- also used for foreach clause of nhd statement - !======================================================== - recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nbase,nvars) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,listp,list,stmt - integer,intent(in):: base - type(pm_ptr),intent(in),optional:: nhd - integer,intent(in),optional:: nbase,nvars - type(pm_ptr):: var,vlist - type(pm_ptr):: cblock2,cblock3,cblock4 - type(pm_ptr):: cblock_main - integer:: i,j,k,n,lbase,vbase,xbase,xbasev,lex_scope - integer:: nlist,iter,iter2,sym,rbase,wbase,name,flags,sindex,sbase - integer:: slot1,slot2,while_var,outmode,rflags - integer(pm_p)::flag - type(pm_ptr):: vlhs,procs,sig,xvar,p - integer:: save_par_state,save_run_flags,save_run_mode - type(pm_ptr):: save_loop_cblock - logical:: iscomm,outer,invar,c_invar - sym=node_sym(stmt) - - wbase=coder%wtop - invar=sym==sym_foreach_invar - c_invar=pm_is_compiling.and.invar - rflags=merge(proc_run_shared+proc_run_always,0,c_invar) - - if(debug_codegen) write(*,*) 'TRAVEACH>' - - lex_scope=push_lex_scope(coder) - rbase=coder%vtop - - ! Process iterator expression - call trav_iter(coder,cblock,list,sym_dims,lbase,vbase,nlist) - - ! Check invariance of for-each-invar expressions - if(invar) then - do i=1,nlist/2 - call code_check_invar(coder,cblock,node_arg(list,i*2),& - coder%vstack(lbase+i)) - enddo - endif - - ! Hide any where clauses (may need them later) - if(base>=0) then - call hide_vars(coder,base+1,coder%top) - endif - - if(.not.pm_is_compiling) then - call make_const(coder,cblock,stmt,node_arg(stmt,4)) - endif - - save_par_state=coder%par_state -!!$ coder%par_state=par_state_for_loop(coder,stmt,coder%par_state,& -!!$ node_get_num(stmt,node_args+3)/=0,sym==sym_foreach_invar) -!!$ - ! Start for-each loop - iter=call_start(coder,cblock,list,invar) - - ! Get array/domain elements for first iteration - xbase=coder%top - do i=1,nlist/2 - call make_var(coder,cblock,list,& - node_arg(list,i*2-1),var_is_var) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_idx)) - call make_sys_call(coder,cblock,list,sym_get_element,2,1,& - aflags=rflags) - enddo - - ! While clause - if(.not.pm_fast_isnull(node_arg(stmt,2))) then - p=node_arg(stmt,2) - if(node_sym(p)==sym_while) then - call code_val(coder,coder%var(iter+lv_end)) - call trav_xexpr(coder,cblock,p,node_arg(p,1)) - if(invar) then - call code_check_invar(coder,cblock,p,top_code(coder)) - endif - call make_sys_call_rtn(coder,cblock,stmt,sym_and,2,1,aflags=rflags) - call make_var_assignment(coder,cblock,stmt,coder%var(iter+lv_end),aflags=rflags) - endif - endif - - coder%lex_scope=lex_scope - - ! Loop body - cblock2=make_cblock(coder,cblock,list,sym_each) - call trav_open_stmt_list(coder,cblock2,stmt,node_arg(stmt,3)) - - ! Modify changed array elements - do i=1,nlist/2 - var=coder%var(xbase+i) - if(cnode_flags_set(var,var_flags,var_is_changed)) then - outmode=trav_ref(coder,cblock2,list,& - node_arg(list,i*2),0) - call code_val(coder,var) - call code_val(coder,coder%var(iter+lv_idx)) - call make_assign_call(coder,cblock2,list,sym_set_element,3,0,aflags=rflags) - endif - enddo - - ! Next iteration - if(.not.pm_fast_isnull(node_arg(stmt,2))) then - ! While/until - p=node_arg(stmt,2) - if(node_sym(p)/=sym_while) then - lex_scope=push_lex_scope(coder) - call trav_xexpr(coder,cblock2,stmt,node_arg(p,1)) - if(sym==sym_foreach_invar) then - call code_check_invar(coder,cblock2,p,top_code(coder)) - endif - coder%lex_scope=lex_scope - cblock_main=make_cblock(coder,cblock2,stmt,sym_each) - call make_const(coder,cblock_main,stmt,coder%false) - call make_var_assignment(coder,cblock_main,stmt,& - coder%var(iter+lv_end),aflags=rflags) - call close_cblock(coder,cblock_main) - cblock_main=make_cblock(coder,cblock2,stmt,sym_each) - call call_next(coder,cblock_main,list,iter,invar) - call close_cblock(coder,cblock_main) - call get_lex_scope(coder,stmt) - call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),4,0) - call pop_lex_scope(coder) - else - call call_next(coder,cblock2,list,iter,invar) - endif - else - call call_next(coder,cblock2,list,iter,invar) - endif - - ! Get elements for next iteration - lex_scope=push_lex_scope(coder) - call code_val(coder,coder%var(iter+lv_end)) - coder%lex_scope=lex_scope - cblock_main=make_cblock(coder,cblock2,stmt,sym_each) - do i=1,nlist/2 - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_idx)) - call make_sys_call_rtn(coder,cblock_main,list,sym_get_element,2,1,aflags=rflags) - call make_var_assignment(coder,cblock_main,stmt,coder%var(xbase+i),aflags=rflags) - enddo - if(.not.pm_fast_isnull(node_arg(stmt,2))) then - p=node_arg(stmt,2) - if(node_sym(p)==sym_while) then - call trav_xexpr(coder,cblock_main,p,node_arg(p,1)) - if(invar) then - call code_check_invar(coder,cblock,p,top_code(coder)) - endif - call make_var_assignment(coder,cblock_main,stmt,& - coder%var(iter+lv_end),aflags=rflags) - endif - endif - call close_cblock(coder,cblock_main) - call code_null(coder) - call get_lex_scope(coder,stmt) - call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),4,0) - call pop_lex_scope(coder) - call close_cblock(coder,cblock2) - - ! Build call - call code_val(coder,coder%var(iter+lv_end)) - call get_lex_scope(coder,stmt) - call make_sp_call(coder,cblock,list,sym_each,4,0) - - ! Clean up - coder%par_state=save_par_state - coder%vtop=rbase - - call pop_vars_to(coder,vbase) - - call pop_lex_scope(coder) - - contains - include 'fisnull.inc' - include 'fisname.inc' - include 'fname.inc' - include 'ftiny.inc' - - end subroutine trav_foreach_stmt - - !========================================================= - ! Call iter,state,end=first(domain) - ! -- Domain must be variable at top of variable (not value) - ! stack and also must not be shared (cannot import) - !========================================================= - function call_start(coder,cblock,list,invar) result(iter) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list - logical,intent(in):: invar - integer:: iter,i - integer:: save_run_flags - - if(invar.and.pm_is_compiling) then - save_run_flags=coder%run_flags - coder%run_flags=proc_run_shared+proc_run_always - endif - - iter=coder%top - - ! Code iter,state,not_end=first(domain) - call code_val(coder,coder%var(iter)) - call make_sys_call_rtn(coder,cblock,list,sym_first,1,3) - - ! Loop end - call define_sys_var(coder,cblock,list,sym_for_stmt,& - var_is_shadowed+var_is_var) - ! State - call define_sys_var(coder,cblock,list,sym_pling,& - var_is_shadowed+var_is_var) - ! Iterator - call define_sys_var(coder,cblock,list,sym_iter,& - var_is_shadowed+var_is_var) - - if(invar) then - do i=coder%top-2,coder%top - call code_val(coder,coder%var(i)) - call code_num(coder,sym_invar) - call make_basic_sp_call(coder,cblock,list,sym_set_mode,2,0,coder%par_depth) - enddo - if(pm_is_compiling) then - coder%run_flags=save_run_flags - endif - endif - - end function call_start - - !======================================================== - ! Code either iter,state,end=next(domain,state,iter) - !======================================================== - subroutine call_next(coder,cblock,list,iter,invar) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list - integer,intent(in):: iter - logical,intent(in):: invar - type(pm_ptr):: dvar,ivar,svar,evar - integer:: save_run_flags - - if(invar.and.pm_is_compiling) then - save_run_flags=coder%run_flags - coder%run_flags=proc_run_shared+proc_run_always - endif - - dvar=coder%var(iter) - ivar=coder%var(iter+lv_idx) - svar=coder%var(iter+lv_state) - evar=coder%var(iter+lv_end) - call code_val(coder,dvar) - call code_val(coder,svar) - call code_val(coder,ivar) - call make_sys_call_rtn(coder,cblock,list,sym_next,3,3) - call make_var_assignment(coder,cblock,list,evar) - call make_var_assignment(coder,cblock,list,svar) - call make_var_assignment(coder,cblock,list,ivar) - - if(invar.and.pm_is_compiling) then - coder%run_flags=save_run_flags - endif - - end subroutine call_next - - - subroutine check_par_context(coder,list_head,node,cond_is_ok) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: list_head,node - logical,intent(in):: cond_is_ok - type(pm_ptr):: list - integer:: i - select case(coder%par_state) - case(par_state_for,par_state_loop,par_state_masked,par_state_over,& - par_state_labelled) - continue - case(par_state_outer) - call code_error(coder,node,& - 'Cannot have communicating operation outside of any parallel statement') - return - case(par_state_nhd) - call code_error(coder,node,& - 'Cannot have communicating operation in the main body of a "nhd" statement') - return - case(par_state_any) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Cannot have active communicating operation in an "any" statement') - endif - case(par_state_cond) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Unlabelled communicating operation in conditional statement') - endif - case(par_state_cond_loop) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Communicating operation in unlabelled loop') - endif - case(par_state_par) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Unlabelled communicating operation in par statement') - endif - case default - write(*,*) 'Par state=',coder%par_state - call pm_panic('Unknown par state') - end select - end subroutine check_par_context - + call close_cblock(coder,cblock3) + call make_sp_call(coder,cblock,p,sym_check,4,0) + end do + contains + include 'fisnull.inc' + end subroutine make_check !======================================================== ! Code a check if value is invariant + ! If sym is present then also check for correct par_state !======================================================== - subroutine code_check_invar(coder,cblock,node,val) + subroutine code_check_invar(coder,cblock,node,val,sym) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,val - if(var_private(coder,val)) then - call code_val(coder,val) - call make_sp_call(coder,cblock,node,sym_invar,1,0,flags=call_is_no_touch) + integer,intent(in),optional:: sym + if(present(sym)) then + if(coder%par_state==par_state_none) then + call code_error(coder,node,'Cannot have "'//trim(sym_names(sym))//'"'//& + ' outside of a parallel context') + elseif(coder%par_state>=par_state_masked) then + call code_error(coder,node,'Cannot have "'//trim(sym_names(sym))//'"'//& + ' inside a conditional statement within the parallel context') + endif endif + call code_val(coder,val) + call make_sp_call(coder,cblock,node,sym_invar,1,0,flags=call_is_no_touch) end subroutine code_check_invar - !======================================================== - ! Iteration clause ' x in A, y in B ' - !======================================================== - recursive subroutine trav_iter(coder,cblock,list,shape_sym,lbase,vbase,nlist) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list - integer,intent(out):: nlist,lbase,vbase - integer,intent(in):: shape_sym - integer:: i - - ! Expressions to iterate over - nlist=node_numargs(list) - lbase=coder%vtop - do i=2,nlist,2 - call trav_expr(coder,cblock,list,node_arg(list,i)) - enddo - - vbase=coder%top - - ! Check that all elements conform - do i=2,nlist/2 - if(node_get_num(list,(i-1)*2+node_args)>0) then - call repl_expr(coder,lbase+1) - call repl_expr(coder,lbase+i) - call make_sys_call(coder,cblock,list,& - sym_check_conform,2,0) - endif - enddo - - ! Calculate common iteration domain from 1st element in list - call repl_expr(coder,lbase+1) - call make_sys_call_rtn(coder,cblock,list,shape_sym,1,1) - call define_sys_var(coder,cblock,list,sym_for,var_is_shadowed) - end subroutine trav_iter - !************************************************** ! PARALLEL STATEMENTS !************************************************** @@ -1975,7 +2388,7 @@ end subroutine trav_iter !!$ base=coder%top !!$ !!$ if(node_numargs(node)==4) then -!!$ call code_error(coder,node,'"par" statement has only one branch') +!$ call code_error(coder,node,'"par" statement has only one branch') !!$ coder%vtop=vstart !!$ return !!$ endif @@ -2082,7 +2495,7 @@ recursive subroutine trav_assign_define(coder,cblock,pnode,node) rhs=node_arg(node,2) sym=node_sym(lhs) n=node_numargs(lhs) - if(sym/=sym_assign) n=n-1 + if(sym/=sym_assign.and.sym/=sym_where) n=n-2 call trav_rhs(coder,cblock,node,rhs,n) call trav_lhs(coder,cblock,node,lhs,rhs) coder%vtop=base @@ -2102,7 +2515,7 @@ recursive subroutine trav_assign_define_list(coder,cblock,pnode,node) lhs=node_arg(assn,1) sym=node_sym(lhs) n=node_numargs(lhs) - if(sym/=sym_assign) n=n-1 + if(sym/=sym_assign) n=n-2 rhs=node_arg(assn,2) call trav_rhs(coder,cblock,node,rhs,n) enddo @@ -2129,10 +2542,14 @@ subroutine trav_lhs(coder,cblock,node,lhs,rhs) sym=node_sym(lhs) select case(sym) case(sym_var,sym_const) - do i=n-1,1,-1 - call trav_cast(coder,cblock,lhs,node_arg(lhs,n),sym) + do i=n-2,1,-1 call make_definition(coder,cblock,lhs,node_arg(lhs,i),& - merge(0,var_is_var,sym==sym_const)) + merge(0,var_is_var,sym==sym_const),node_arg(lhs,n),& + node_num_arg(lhs,n-1)) + enddo + case(sym_where) + do i=n,1,-1 + call make_definition(coder,cblock,lhs,node_arg(lhs,i),0) enddo case(sym_assign) if(node_sym(rhs)==sym_assign) then @@ -2154,12 +2571,11 @@ subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) type(code_state):: coder type(pm_ptr),intent(in):: cblock,node,lhs,rhs type(pm_ptr):: var - type(pm_ptr):: name - integer:: rsym + integer:: name if(pm_fast_isname(lhs)) then - name=lhs + name=lhs%offset elseif(node_sym(lhs)==sym_name) then - name=node_arg(lhs,1) + name=node_num_arg(lhs,1) elseif(node_sym(lhs)==sym_lt) then call make_op_assignment_noalias(coder,cblock,lhs,node_arg(lhs,1),node_arg(lhs,2)) return @@ -2199,6 +2615,18 @@ subroutine trav_rhs(coder,cblock,node,rhs,n) do i=2,n call dup_expr(coder,top_code(coder)) enddo + elseif(rsym==sym_do_stmt) then + do i=1,n + call make_temp_var(coder,cblock,node) + enddo + call make_block_proc(coder,cblock,node_arg(rhs,3),& + node_arg(rhs,1),node_num_arg(rhs,2),& + node_arg(rhs,5),node_numargs(node_arg(rhs,5)),& + node_arg(rhs,4)) + do i=1,n + call code_val(coder,coder%vstack(base+i)) + enddo + call trav_call(coder,cblock,node,node_arg(rhs,3),n,.true.) elseif(n>1) then do i=1,n call make_temp_var(coder,cblock,node) @@ -2212,38 +2640,6 @@ subroutine trav_rhs(coder,cblock,node,rhs,n) endif end subroutine trav_rhs - !======================================================== - ! Traverse sync lhs = rhs - !======================================================== - subroutine trav_sync_assign(coder,cblock,pnode,node) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer:: save_par_state,n,base - n=node_numargs(node) - base=coder%top - ! Make a shadow variable to prevent access to LHS var on RHS - ! or subscripts - ! This keeps a link to the node to ensure that we can still - ! access variable in the one place we need to - call make_var(coder,cblock,node,node_arg(node_arg(node,1),1),& - var_is_shadowed+var_is_sync+var_is_var,extra_info=node_arg(node,1)) - call drop_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,n)) - call check_par_context(coder,cblock,pnode,.false.) - save_par_state=coder%par_state - coder%in_sync=.true. - if(n==3) then - call make_assignment_noalias(coder,cblock,node,node_arg(node,2)) - else - call make_op_assignment_noalias(coder,cblock,node,& - node_arg(node,2),node_arg(node,3)) - endif - ! Null out link to node to prevent retaining link to module - call cnode_set(coder%context,coder%var(base+1),var_extra_info,pm_null_obj) - call pop_vars_to(coder,base) - coder%par_state=save_par_state - end subroutine trav_sync_assign - !======================================================== ! Assign expression on top of stack to lhs in node ! Need to also provide rhs node (which has already been @@ -2255,42 +2651,42 @@ recursive subroutine make_assignment(coder,cblock,pnode,lhs,rhs,avar) type(pm_ptr),intent(in),optional:: avar integer:: rsym,lsym,rbase,lbase,i,lex_scope logical:: ok - type(pm_ptr):: rname,lname,cblock1,cblock2 + type(pm_ptr):: rname,lname rsym=node_sym(rhs) lsym=node_sym(lhs) - if(rsym==sym_sub.and.lsym==sym_sub) then - rbase=coder%vtop - ok=get_ref_pattern(coder,rhs,rname) - lbase=coder%vtop - ok=get_ref_pattern(coder,lhs,lname) - if(lname%offset/=rname%offset) then - coder%vtop=rbase - call make_assignment_noalias(coder,cblock,pnode,lhs,avar) - elseif(match_ref_names(coder,cblock,pnode,rbase,lbase)) then - coder%vtop=rbase - call make_assignment_noalias(coder,cblock,pnode,lhs,avar) - else - ! Code if : else: - lex_scope=push_lex_scope(coder) - call match_ref_pattern(coder,cblock,pnode,rbase,lbase,test=.true.) - coder%vstack(rbase+1)=coder%vstack(coder%vtop) - coder%vtop=rbase+1 - coder%lex_scope=lex_scope - cblock1=make_cblock(coder,cblock,pnode,sym_if) - call code_val(coder,coder%vstack(rbase)) - call make_assignment_noalias(coder,cblock1,pnode,lhs,avar,alias=.true.) - call close_cblock(coder,cblock1) - cblock2=make_cblock(coder,cblock,pnode,sym_if) - call code_val(coder,coder%vstack(rbase)) - call make_assignment_noalias(coder,cblock2,pnode,lhs,avar) - call close_cblock(coder,cblock2) - call get_lex_scope(coder,pnode) - call make_sp_call(coder,cblock,pnode,sym_if,4,0) - call pop_lex_scope(coder) - endif - else +!!$ if(rsym==sym_sub.and.lsym==sym_sub) then +!!$ rbase=coder%vtop +!!$ ok=get_ref_pattern(coder,rhs,rname) +!!$ lbase=coder%vtop +!!$ ok=get_ref_pattern(coder,lhs,lname) +!!$ if(lname%offset/=rname%offset) then +!!$ coder%vtop=rbase +!!$ call make_assignment_noalias(coder,cblock,pnode,lhs,avar) +!!$ elseif(match_ref_names(coder,cblock,pnode,rbase,lbase)) then +!!$ coder%vtop=rbase +!!$ call make_assignment_noalias(coder,cblock,pnode,lhs,avar) +!!$ else +!!$ ! Code if : else: +!!$ lex_scope=push_lex_scope(coder) +!!$ call match_ref_pattern(coder,cblock,pnode,rbase,lbase,test=.true.) +!!$ coder%vstack(rbase+1)=coder%vstack(coder%vtop) +!!$ coder%vtop=rbase+1 +!!$ coder%lex_scope=lex_scope +!!$ cblock1=make_cblock(coder,cblock,pnode,sym_if) +!!$ call code_val(coder,coder%vstack(rbase)) +!!$ call make_assignment_noalias(coder,cblock1,pnode,lhs,avar,alias=.true.) +!!$ call close_cblock(coder,cblock1) +!!$ cblock2=make_cblock(coder,cblock,pnode,sym_if) +!!$ call code_val(coder,coder%vstack(rbase)) +!!$ call make_assignment_noalias(coder,cblock2,pnode,lhs,avar) +!!$ call close_cblock(coder,cblock2) +!!$ call get_lex_scope(coder,pnode) +!!$ call make_sp_call(coder,cblock,pnode,sym_if,4,0) +!!$ call pop_lex_scope(coder) +!!$ endif +!!$ else call make_assignment_noalias(coder,cblock,pnode,lhs,avar) - endif +!!$ endif end subroutine make_assignment !============================================================ @@ -2303,36 +2699,31 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) type(pm_ptr),intent(in):: cblock,pnode,node type(pm_ptr),intent(in),optional:: avar logical,intent(in),optional:: alias - integer:: n,i,sym,flags,mode,depth,outmode - type(pm_ptr):: v,w - logical:: outer,shared + integer:: sym,outmode if(present(avar)) then - call trav_ref_to_var(coder,cblock,pnode,node,0,avar) - call assign_call(pnode,outer,& + call trav_ref_to_var(coder,cblock,pnode,0,.true.,avar) + call assign_call(pnode,& cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - cnode_flags_set(top_code(coder),var_flags,var_is_not_inited),& - .false.) + cnode_flags_set(top_code(coder),var_flags,var_is_not_inited)) elseif(node_sym(node)==sym_underscore) then call drop_code(coder) return elseif(pm_fast_isname(node)) then - call trav_ref_to_var(coder,cblock,pnode,node,0) - call assign_call(pnode,outer,& + call trav_ref_to_var(coder,cblock,pnode,int(node%offset),.true.) + call assign_call(pnode,& cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - cnode_flags_set(top_code(coder),var_flags,var_is_not_inited),& - .false.) + cnode_flags_set(top_code(coder),var_flags,var_is_not_inited)) else sym=node_sym(node) select case(sym) - case(sym_sub,sym_dot_sub,sym_dot,sym_get_dot,sym_at,sym_pling,sym_open_smiley) - outmode=trav_ref(coder,cblock,pnode,node,0) - call assign_call(node,outer,.false.,.false.,iand(outmode,ref_has_at)/=0) + case(sym_reference) + call trav_simple_ref(coder,cblock,pnode,node,.true.) + call assign_call(node,.false.,.false.) case(sym_name) - call trav_ref_to_var(coder,cblock,node,node_arg(node,1),0) - call assign_call(node,outer,& + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),.true.) + call assign_call(node,& cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - cnode_flags_set(top_code(coder),var_flags,var_is_not_inited),& - .false.) + cnode_flags_set(top_code(coder),var_flags,var_is_not_inited)) case default !write(*,*) sym_names(sym) call code_error(coder,pnode,& @@ -2344,707 +2735,264 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) include 'fisname.inc' include 'fisnull.inc' include 'ftiny.inc' - - subroutine assign_call(pnode,outer,simple,undef,has_pling) - type(pm_ptr),intent(in):: pnode - logical,intent(in):: outer,simple,undef,has_pling - type(pm_ptr):: v,w - if(.not.coder%in_sync) then - if(simple.and.undef) then - call dup_code(coder) - call swap_code_2_1(coder) - call make_sys_call(coder,cblock,pnode,& - sym_assign_or_init,2,1,aflags=call_is_uninitialised) - else - call swap_code(coder) - call make_assign_call(coder,cblock,pnode,& - merge(sym_aliased_assign,& - merge(sym_assign_var,sym_assignment,simple),& - present(alias)),& - 2,0,aflags=call_is_assign_call) - endif - else - v=pop_code(coder) - w=pop_code(coder) - call code_val(coder,v) - call code_val(coder,w) - call make_static_bool_const(coder,cblock,pnode,has_pling) - call check_par_context(coder,cblock,pnode,.true.) - call make_comm_sys_call(coder,cblock,pnode,& - merge(sym_aliased_assign,sym_assignment,present(alias)),& - 3,0,assign=.true.) - endif - end subroutine assign_call - - end subroutine make_assignment_noalias - - !======================================================== - ! Assign expression on top of stack to lhs in node - !======================================================== - recursive subroutine make_op_assignment_noalias(coder,cblock,pnode,node,op) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node,op - integer:: n,i,sym,flags,mode,depth,outmode - type(pm_ptr):: v,w - logical:: outer,shared - if(node_sym(node)==sym_underscore) then - call drop_code(coder) - return - endif - outmode=trav_ref(coder,cblock,pnode,node,0) - if(coder%in_sync) then - v=pop_code(coder) - w=pop_code(coder) - call code_val(coder,v) - call code_val(coder,w) - if(node_sym(op)==sym_proc.and.node_sym(node_arg(op,1))==sym_minus) then - call make_sys_call_rtn(coder,cblock,pnode,sym_minus,1,1) - endif - call trav_expr(coder,cblock,pnode,op) - call make_static_bool_const(coder,cblock,pnode,& - iand(outmode,ref_has_at)/=0) - call check_par_context(coder,cblock,pnode,.true.) - call make_comm_sys_call(coder,cblock,pnode,& - sym_assignment,4,0,assign=.true.) - call check_par_context(coder,cblock,pnode,.false.) - else - call swap_code(coder) - if(node_sym(op)==sym_proc.and.node_sym(node_arg(op,1))==sym_minus) then - call make_sys_call_rtn(coder,cblock,pnode,sym_minus,1,1) - endif - call trav_expr(coder,cblock,pnode,op) - call make_assign_call(coder,cblock,pnode,sym_assignment,3,0) - endif - end subroutine make_op_assignment_noalias - - !=================================================================== - ! Use expression on top of stack to create new variable or constant - !=================================================================== - recursive subroutine make_definition(coder,cblock,node,vname,flags) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,vname - integer,intent(in):: flags - integer:: junk,depth - type(pm_ptr):: name,pnode,expr,var - - if(node_sym(vname)==sym_name) then - name=node_arg(vname,1) - pnode=vname - else - name=vname - pnode=node - endif - if(pm_fast_isname(name)) then - call make_var(coder,cblock,pnode,name,flags) - var=top_code(coder) - call swap_code(coder) - call make_sys_call(coder,cblock,pnode,& - merge(sym_dup,sym_clone,iand(flags,var_is_var)/=0),& - 1,1,aflags=coder%run_flags) - call make_var_mode(coder,cblock,node,var) - elseif(node_sym(name)==sym_underscore) then - call drop_code(coder) - else - call code_error(coder,node,& - 'Left hand side of definition must be variable name') - endif - contains - include 'fisname.inc' - include 'fvkind.inc' - include 'fisnull.inc' - end subroutine make_definition - - !=================================================================== - ! Use expression on top of stack to initialise a constant - !=================================================================== - recursive subroutine make_split_definition(coder,cblock,node,var) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,var - call code_val(coder,var) - call make_sp_call(coder,cblock,node,sym_const,1,0) - call code_val(coder,var) - call swap_code(coder) - call make_sys_call(coder,cblock,node,sym_clone,& - 1,1) - call update_change_lists(coder,var,.true.) - end subroutine make_split_definition - - !======================================================== - ! Reference to a variable - !======================================================== - subroutine trav_ref_to_var(coder,cblock,pnode,name,mode,avar) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,name - integer,intent(in):: mode - type(pm_ptr),intent(in),optional:: avar - type(pm_ptr):: var - integer:: depth,flags,var_index - if(present(avar)) then - var=avar - else - var=find_var_and_entry(coder,name,var_index) - if(pm_fast_isnull(var)) then - call code_error(coder,pnode,& - 'Variable has not been defined: ',name) - call make_temp_var(coder,cblock,pnode) - return - endif - endif - flags=cnode_get_num(var,var_flags) - - if(iand(flags,var_is_sync)/=0) then - if(.not.(cnode_get(var,var_extra_info)==pnode)) then - call code_error(coder,pnode,& - 'Cannot access "sync" left-hand-side variable in right-hand-side expression or subscript') - endif - call hide_vars(coder,var_index,var_index) - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call code_error(coder,pnode,& - 'Variable has not been defined: ',name) - call make_temp_var(coder,cblock,pnode) - return - endif - flags=cnode_get_num(var,var_flags) - call reveal_vars(coder,var_index,var_index) - endif - - if(iand(flags,var_is_aliased)/=0) then - coder%aliased=.true. - var=cnode_get(var,var_extra_info) - endif - if(.not.iand(mode,ref_is_val)/=0) then - if(iand(flags,var_is_var)==0) then - call code_error(coder,pnode,& - 'Cannot assign to constant: ',name) - else - call access_var(coder,var,.true.) - endif - endif - if(iand(mode,ref_is_val)/=0) then -! var=import_to_par_scope(coder,cblock,pnode,var,coder%par_depth) - endif - call code_val(coder,var) - if(iand(mode,ref_is_val)==0) then - if(coder%par_state>par_state_outer.and..not.coder%in_sync& - .and.iand(mode,ref_ignores_rules)==0) then - if(par_depth(coder,var)=par_state_cond.and.& - coder%par_state<=par_state_par) then - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,pnode,& - sym_assignment,1,0,coder%par_depth) - endif - endif - contains - include 'fisnull.inc' - end subroutine trav_ref_to_var - - !======================================================== - ! Traverse a reference value - !======================================================== - recursive function trav_ref(coder,cblock,pnode,node,mode) result(outmode) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer,intent(in):: mode - integer:: outmode - logical:: outer - integer:: newmode,sym,n,m,flags,depth,save_run_flags - logical:: d_index - integer:: aflags,acall,i - type(pm_ptr):: p,q - outer=.false. - outmode=0 - if(pm_fast_isname(node)) then - call trav_ref_to_var(coder,cblock,pnode,node,mode) - else if(pm_fast_vkind(node)==pm_pointer) then - sym=node_sym(node) - select case(sym) - case(sym_sub,sym_dot_sub) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - p=node_arg(node,2) - d_index=trav_index_list(coder,cblock,p,iand(mode,ref_is_val)/=0) - newmode=trav_ref(coder,cblock,node,node_arg(node,1),& - merge(ior(mode,ref_is_dollar),mode,d_index)) - p=pop_code(coder) - q=pop_code(coder) - aflags=call_inline_when_compiling - if(iand(mode,ref_is_val)/=0) then - acall=merge(sym_make_noderef,sym_make_subref,sym==sym_dot_sub) - else - if(iand(mode,ref_is_amp)/=0) then - acall=merge(sym_make_nodelhs_amp,sym_make_sublhs_amp,sym==sym_dot_sub) - !call code_error(coder,node,'Cannot have "[]" in "&" argument') - else - acall=merge(sym_make_nodelhs,sym_make_sublhs,sym==sym_dot_sub) - endif - endif - if(coder%in_sync.or.& - coder%par_state>par_state_outer.and.iand(mode,ref_is_val)/=0) then - call code_val(coder,p) - call code_val(coder,q) - call make_comm_sys_call(coder,cblock,node,acall,2,1,& - aflags=aflags) - call check_par_context(coder,cblock,node,.true.) - else - if(sym==sym_dot_sub) then - if(iand(mode,ref_is_val)/=0) then - call code_error(coder,node,& - 'Cannot have a ".[]" subscript outside of a parallel context') - else - call code_error(coder,node,& - 'Cannot assign to a ".[]" subscript outside of a "sync" statement') - endif - call drop_code(coder) - else - call code_val(coder,p) - call code_val(coder,q) - call make_sys_call(coder,cblock,node,acall,2,1,aflags=ior(aflags,call_ignore_rules)) - endif - endif - outmode=ior(outmode,merge(ref_is_dollar+ref_is_subscripted,& - ref_is_subscripted,d_index)) - case(sym_dot) - call make_temp_var(coder,cblock,pnode) - call dup_code(coder) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - depth=par_depth(coder,top_code(coder)) - call make_const(coder,cblock,node,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,& - merge(sym_dot,sym_dot_ref,& - iand(mode,ref_is_val)/=0),2,1,depth) - call var_set_par_depth(coder,top_code(coder),depth) - case(sym_get_dot) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - call trav_expr(coder,cblock,node,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,& - merge(sym_get_dot,sym_get_dot_ref,& - iand(mode,ref_is_val)/=0),2,1,coder%par_depth) - case(sym_get_dot_ref) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - call trav_expr(coder,cblock,node,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,& - sym_get_dot_ref,2,1,coder%par_depth) - case(sym_open_smiley) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - do i=1,node_numargs(node) - outmode=trav_ref(coder,cblock,node,node_arg(node,i),mode) - enddo - call make_sp_call(coder,cblock,node,sym_open_smiley,node_numargs(node),1) - case(sym_caret) - save_run_flags=coder%run_flags - coder%run_flags=ior(coder%run_flags,call_inline_when_compiling) - call trav_expr(coder,cblock,pnode,node_arg(node,1)) - coder%run_flags=save_run_flags - outmode=0 - case(sym_pling) - if(iand(mode,ref_is_val+ref_ignores_rules)==0.and..not.coder%in_sync) then - call code_error(coder,node,& - 'Cannot change value of "!" expression outside of a "sync" statement') - endif - call check_par_context(coder,cblock,node,.false.) - outmode=ior(trav_ref(coder,cblock,node,node_arg(node,1),mode),& - ref_has_at) - call make_comm_sys_call_rtn(coder,cblock,node,sym_make_array,1,1,aflags=proc_run_complete) - !call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_num(coder,sym_shared) - call make_basic_sp_call(coder,cblock,node,sym_set_mode,2,0,coder%par_depth) - call check_par_context(coder,cblock,node,.true.) - case(sym_name) - call trav_ref_to_var(coder,cblock,node,node_arg(node,1),mode) - outmode=0 - case(sym_dot_call) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - call trav_exprlist(coder,cblock,node,node_arg(node,3)) - call make_comm_sys_call_rtn(coder,cblock,node,node_num_arg(node,2),& - node_numargs(node_arg(node,3))+1,1,aflags=proccall_is_ref,assign=.true.) - case default - if(iand(mode,ref_is_val)==0) then - call code_error(coder,pnode,& - 'Cannot indirectly assign to expression - value is updated') - call dump_parse_tree(coder%context,6,node,2) - call make_temp_var(coder,cblock,pnode) - else - call trav_expr(coder,cblock,pnode,node) - endif - end select - else - call code_error(coder,pnode,& - 'Cannot make reference') - call make_temp_var(coder,cblock,pnode) - endif - contains - include 'fvkind.inc' - include 'fisname.inc' - include 'fisnull.inc' - include 'ftiny.inc' - end function trav_ref - - !========================================================== - ! Create alias checks for argument #j in argument list/amp - ! Will raise an error if alias is detectable at compile time - ! Will code run-time checks if needed - ! Will set vstack[argbase+i] to a tiny int value - ! (or increment existing tiny int value) - ! if argument #i definitely does not alias argument #j - !========================================================== - - ! BROKEN _ Does bad things to vstack (probably called with wrong argbase) - subroutine trav_alias_checks(coder,cblock,list,amp,j,argbase) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list,amp - integer,intent(in):: j,argbase - integer:: i,k,base1,base2 - logical:: finished - type(pm_ptr):: p,name,name2,var - return - p=node_arg(list,j) - p=node_arg(p,1) - base1=coder%vtop - name=pm_null_obj - finished=get_ref_pattern(coder,p,name) - if(pm_fast_isnull(name)) return - k=0 - do i=1,node_numargs(list) - p=node_arg(list,i) - if(amp%data%i(amp%offset+k)==i) then - k=min(pm_fast_esize(amp),k+1) - if(node_sym(p)==sym_amp) then - if(i>=j) cycle - p=node_arg(p,1) - base2=coder%vtop - finished=get_ref_pattern(coder,p,name2) - if(.not.pm_fast_isnull(name2)) then - call match_ref_pattern(coder,cblock,p,base1,base2,& - j,i,list) - endif - else - cycle - endif - elseif(node_sym(p)==sym_dot.or.node_sym(p)==sym_sub) then - base2=coder%vtop - finished=get_ref_pattern(coder,p,name2) - if(.not.pm_fast_isnull(name2)) then - if(match_ref_names(coder,cblock,p,base1,base2)) then - if(pm_fast_vkind(coder%vstack(argbase+i))==pm_tiny_int) then - coder%vstack(argbase+i)%offset=& - coder%vstack(argbase+i)%offset+1 - else - coder%vstack(argbase+i)=pm_fast_tinyint(coder%context,1) - endif - endif - endif - endif - enddo - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call make_temp_var(coder,cblock,list) - var=pop_code(coder) - endif - if(cnode_flags_clear(var,var_flags,var_is_aliased)) then - call make_var(coder,cblock,p,name,& - var_is_var+var_is_aliased+var_is_shadowed,var) - endif - coder%vtop=base1 - contains - include 'fesize.inc' - include 'fisnull.inc' - include 'ftiny.inc' - include 'fvkind.inc' - end subroutine trav_alias_checks - - !============================================================ - ! Get the pattern of .name and [] subscripts in a reference - ! -- truncated after @ - !============================================================ - recursive function get_ref_pattern(coder,node,name) result(finished) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node - type(pm_ptr),intent(inout):: name - logical:: finished - integer:: sym - sym=node_sym(node) - select case(sym) - case(sym_sub) - finished=get_ref_pattern(coder,node_arg(node,1),name) - if(.not.finished) call code_val(coder,node) - case(sym_dot) - finished=get_ref_pattern(coder,node_arg(node,1),name) - if(.not.finished) call code_val(coder,node_arg(node,2)) - case(sym_at,sym_pling) - finished=get_ref_pattern(coder,node_arg(node,1),name) - finished=.true. - case(sym_name) - name=node_arg(node,1) - call code_val(coder,name) - finished=.false. - case default - finished=.true. - end select - contains - include 'fname.inc' - end function get_ref_pattern - - !======================================================================= - ! Match reference patterns in coder%vstack(base1+1..base2) and - ! coder%vstack(base2+1..coder%vtop) coding runtime checks when needed - ! Either - ! Compile alias checking of arguments (provide idx1,idx2,list) - ! Or - ! Compile alias check between two references (provide test) - !======================================================================= - subroutine match_ref_pattern(coder,cblock,node,base1,base2,idx1,idx2,list,test) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: base1,base2 - integer,intent(in),optional:: idx1,idx2 - type(pm_ptr),intent(in),optional:: list - logical,intent(in),optional:: test - type(pm_ptr):: p1,p2 - integer:: i,j,n1,n2,m,vbase - logical:: has_dollar - - n1=base2-base1 - n2=coder%vtop-base2 - if(n1==0.or.n2==0) return - - if(.not.present(test)) then - ! Check is cross matching of .name proves no alias is possible - if(match_ref_names(coder,cblock,node,base1,base2)) return - endif + + subroutine assign_call(pnode,simple,undef) + type(pm_ptr),intent(in):: pnode + logical,intent(in):: simple,undef + if(simple.and.undef) then + call dup_code(coder) + call swap_code_2_1(coder) + call make_sys_call(coder,cblock,pnode,& + sym_assign_or_init,2,1,aflags=call_is_uninitialised) + else + call swap_code(coder) + call make_assign_call(coder,cblock,pnode,& + merge(sym_aliased_assign,& + merge(sym_assign_var,sym_assignment,simple),& + present(alias)),& + 2,0,aflags=call_is_assign_call) + endif + end subroutine assign_call - ! May alias - code any required run-time subscript checks - if(present(test)) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call dup_expr(coder,coder%vstack(base1)) - m=1 - else - call make_int_const(coder,cblock,node,idx1) - call make_int_const(coder,cblock,node,idx2) - m=2 + end subroutine make_assignment_noalias + + !======================================================== + ! Assign expression on top of stack to lhs in node + !======================================================== + recursive subroutine make_op_assignment_noalias(coder,cblock,pnode,node,op) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,pnode,node,op + integer:: n + if(node_sym(node)==sym_underscore) then + call drop_code(coder) + return endif - i=1 - j=1 - do while(i<=n1.and.j<=n2) - p1=coder%vstack(base1+i) - p2=coder%vstack(base2+j) - - ! Check for matching "[]" in both arguments - if(.not.pm_fast_isname(p1).and..not.pm_fast_isname(p2)) then - - ! Code subscript in 1st argument - has_dollar=trav_index_list(coder,cblock,node_arg(p1,2),.true.) - - ! Check for and consolidate subsequent subscripts - i=i+1 - if(i<=n1) then - p1=coder%vstack(base1+i) - if(.not.pm_fast_isname(p1)) then - vbase=coder%vtop-1 - do while(.not.pm_fast_isname(p1)) - has_dollar=trav_index_list(coder,cblock,node_arg(p1,2),.true.) - i=i+1 - if(i>n1) exit - p1=coder%vstack(base1+i) - enddo - call make_sys_call_rtn(coder,cblock,node,sym_combine_indices,& - coder%vtop-vbase,1) + call trav_simple_ref(coder,cblock,pnode,node,.true.) + call swap_code(coder) + call trav_expr(coder,cblock,pnode,op) + call make_assign_call(coder,cblock,pnode,sym_assignment,3,0) + end subroutine make_op_assignment_noalias + + !=================================================================== + ! Use expression on top of stack to create new variable or constant + !=================================================================== + recursive subroutine make_definition(coder,cblock,node,vname,flags,vtype,mode) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,node,vname + integer,intent(in):: flags + type(pm_ptr),intent(in),optional:: vtype + integer,intent(in),optional:: mode + type(pm_ptr):: pnode,var + integer:: name,has_type + integer:: vcall,vflags + logical:: has_mode + + if(node_sym(vname)==sym_name.or.pm_fast_isname(vname)) then + if(pm_fast_isname(vname)) then + name=vname%offset + pnode=node + else + name=node_num_arg(vname,1) + pnode=vname + endif + has_mode=present(mode) + if(has_mode) has_mode=mode>0 + vflags=flags + if(has_mode) vflags=ior(vflags,var_is_maybe_not_private) + if(iand(flags,var_is_var)==0) then + var=top_code(coder) + if(cnode_get_kind(var)==cnode_is_var) then + if(cnode_flags_set(var,var_flags,var_is_maybe_not_private)) then + vflags=ior(vflags,var_is_maybe_not_private) endif endif - - ! Code subscript in 2nd argument - has_dollar=trav_index_list(coder,cblock,node_arg(p2,2),.true.) - - ! Check for and consolidate subsequent subscripts - j=j+1 - if(j<=n2) then - p2=coder%vstack(base2+j) - if(.not.pm_fast_isname(p2)) then - vbase=coder%vtop-1 - do while(.not.pm_fast_isname(p2)) - has_dollar=trav_index_list(coder,cblock,node_arg(p2,2),.true.) - j=j+1 - if(j>n2) exit - p2=coder%vstack(base2+j) - enddo - call make_sys_call_rtn(coder,cblock,node,sym_combine_indices,& - coder%vtop-vbase,1) - endif + endif + call make_var(coder,cblock,pnode,name,vflags) + var=top_code(coder) + call swap_code(coder) + has_type=0 + if(present(vtype)) then + if(.not.pm_fast_isnull(vtype)) then + has_type=1 + call trav_type_constraint(coder,node,vtype) + call make_const(coder,cblock,node,& + pm_fast_tinyint(coder%context,pop_word(coder))) + call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) endif - - ! Now have 2 more arguments for alias checker - m=m+2 - elseif(pm_fast_isname(p1).and.pm_fast_isname(p2)) then - ! Matching .name in both arguments - just skip - i=i+1 - j=j+1 - else - ! Matching .name with [] - ! This situation cannot occur with type-correct code - ! So quit here - a type error will be raised later, - ! while an alias error would be confusing - coder%vtop=coder%vtop-m - return endif - enddo - if(m<=2) then - if(.not.present(test)) then - ! There were no subscripts, so clash can be confirmed at compile time - call code_error(coder,node_arg(list,idx2),& - 'Argument aliased by "&" argument') - call code_error(coder,node_arg(list,idx1),& - 'Argument causing the alias') + vcall=merge(sym_make_var,sym_make_const,iand(flags,var_is_var)/=0) + if(coder%par_state>par_state_none) then + ! Assumes cannot have "const" in a mode statement + if(has_mode) vcall=vcall+mode-sym_chan+1 + call make_comm_sys_call(coder,cblock,pnode,vcall,1+has_type,1) + else + if(has_mode) call code_error(coder,node,'Cannot have a "'//& + trim(sym_names(mode))//' var" statement outside of a parallel context') + call make_sys_call(coder,cblock,pnode,vcall,1+has_type,1) endif - coder%vtop=coder%vtop-2 + elseif(node_sym(vname)==sym_underscore) then + call drop_code(coder) else - ! Code call to check for subscript aliasing - call make_sys_call(coder,cblock,node,sym_check_alias,m,& - merge(1,0,present(test))) + call code_error(coder,node,& + 'Left hand side of definition must be variable name') endif contains include 'fisname.inc' include 'fvkind.inc' - end subroutine match_ref_pattern - + include 'fisnull.inc' + include 'ftiny.inc' + end subroutine make_definition - !======================================================================= - ! Match reference patterns in coder%vstack(base1+1..base2) and - ! coder%vstack(base2+1..coder%vtop) to compare presence of .name - ! qualifiers to see if mismatch proves no aliasing is possible - !======================================================================= - function match_ref_names(coder,cblock,node,base1,base2) & - result(differ) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: base1,base2 - logical:: differ - type(pm_ptr):: p1,p2 - integer:: i,j,n1,n2,m,vbase - logical:: has_dollar - differ=.false. - n1=base2-base1 - n2=coder%vtop-base2 - if(n1==0.or.n2==0) return - i=1 - j=1 - do while(i<=n1.and.j<=n2) - p1=coder%vstack(base1+i) - p2=coder%vstack(base2+j) - if(pm_fast_isname(p1).and.pm_fast_isname(p2)) then - ! Compare "." names - if(p1%offset/=p2%offset) then - differ=.true. - return - endif - i=i+1 - j=j+1 - else - ! Skip past "[]" subscripts - if(.not.pm_fast_isname(p1)) then - i=i+1 - endif - if(.not.pm_fast_isname(p2)) then - j=j+1 - endif - endif - enddo - contains - include 'fisname.inc' - end function match_ref_names + !=================================================================== + ! Use expression on top of stack to initialise a constant + !=================================================================== + recursive subroutine make_split_definition(coder,cblock,node,var) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,node,var + call code_val(coder,var) + call make_sp_call(coder,cblock,node,sym_const,1,0) + call code_val(coder,var) + call swap_code(coder) + call make_sys_call(coder,cblock,node,sym_clone,& + 1,1) + call update_change_lists(coder,var,.true.) + end subroutine make_split_definition !======================================================== - ! Subscripts (including dollar subscripts) + ! Reference to a variable !======================================================== - recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) + subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - logical,optional,intent(in):: is_val - logical:: has_dollar - integer:: n,flags - integer:: i,j,save_subs_index,max_idx - logical:: replicated - integer:: which(0:8) - type(pm_ptr):: p - logical:: has_underscore_error - has_underscore_error=.false. - flags=0 - n=node_numargs(node) - save_subs_index=coder%subs_index - which=0 - replicated=.false. - max_idx=0 - do i=1,n - coder%subs_index=0 - p=node_arg(node,i) - if(node_sym(p)==sym_underscore) then - p=find_param(coder,cblock,node,& - pm_fast_name(coder%context,sym_stretch_dim)) - if(pm_fast_isnull(p)) call pm_panic('Cant find stretch dim') - call code_val(coder,p) - if(.not.present(is_val).and..not.has_underscore_error) then - call code_error(coder,node_arg(node,i),& - 'Cannot have "_" in a left-hand-side subscript') - has_underscore_error=.true. - endif - else - call trav_expr(coder,cblock,& - node,node_arg(node,i)) + type(pm_ptr),intent(in):: cblock,pnode + integer,intent(in):: name + logical,intent(in):: islhs + type(pm_ptr),intent(in),optional:: avar + type(pm_ptr):: var + integer:: flags,var_index + if(present(avar)) then + var=avar + else + var=find_var_and_entry(coder,name,var_index) + if(pm_fast_isnull(var)) then + call code_error(coder,pnode,& + 'Variable has not been defined: ',name) + call make_temp_var(coder,cblock,pnode) + return endif - j=coder%subs_index - replicated=replicated.or.(which(j)>0.and.j>0) - which(j)=i - max_idx=max(max_idx,j) - enddo - if(node_sym(node)==sym_dotdotdot) then - flags=call_is_vararg - endif - if(which(1)>0.and.n/=1) then - call code_error(coder,node,& - 'Cannot use "$" without ".dimension" in subscript with more than one argument') - endif - if(n>1.or.node_sym(node)==sym_dotdotdot) then - call make_sys_call_rtn(coder,cblock,node,sym_tuple,n,1,& - aflags=flags) endif - if(max_idx>0) then - if(coder%par_state==par_state_outer) then - call code_error(coder,node,'Cannot have "$" index outside of any parallel context') - endif - coder%temp2=pop_code(coder) - call code_val(coder,coder%temp2) - coder%temp2=pm_null_obj - if(max_idx>1.and.all(which(2:max_idx)>0)) then - do i=2,max_idx - if(which(i)>0) then - call make_static_long_const(coder,cblock,node,int(which(i),pm_ln)) - else - call make_const(coder,cblock,node,pm_null_obj,int(pm_null)) - endif - end do - call make_sys_call_rtn(coder,cblock,node,sym_tuple,max_idx-1,1) - call make_sys_call_rtn(coder,cblock,node,sym_make_dtuple,2,1) + + if(islhs) then + if(cnode_get_kind(var)==cnode_is_var) then + flags=cnode_get_num(var,var_flags) + if(iand(flags,var_is_var)==0) then + call code_error(coder,pnode,& + 'Cannot assign to constant: ',name) + else + call access_var(coder,var,.true.) + endif else - call make_sys_call_rtn(coder,cblock,node,sym_make_dtuple,1,1) + call code_error(coder,pnode,& + 'Cannot assign to constant: ',name) endif endif - coder%subs_index=save_subs_index - has_dollar=max_idx>0 + call code_val(coder,var) contains - include 'fname.inc' include 'fisnull.inc' - end function trav_index_list + end subroutine trav_ref_to_var + +!!$ !======================================================== +!!$ ! Traverse a reference value +!!$ !======================================================== +!!$ recursive function trav_ref(coder,cblock,pnode,node,mode) result(outmode) +!!$ type(code_state),intent(inout):: coder +!!$ type(pm_ptr),intent(in):: cblock,pnode,node +!!$ integer,intent(in):: mode +!!$ integer:: outmode +!!$ logical:: outer +!!$ integer:: sym,flags +!!$ integer:: acall,i +!!$ outer=.false. +!!$ outmode=0 +!!$ if(pm_fast_isname(node)) then +!!$ call trav_ref_to_var(coder,cblock,pnode,node,mode) +!!$ else if(pm_fast_vkind(node)==pm_pointer) then +!!$ sym=node_sym(node) +!!$ select case(sym) +!!$ case(sym_sub,sym_dot_sub) +!!$ if(iand(mode,ref_is_val)/=0) then +!!$ acall=merge(sym_make_noderef,sym_make_subref,sym==sym_dot_sub) +!!$ else +!!$ if(iand(mode,ref_is_amp)/=0) then +!!$ acall=merge(sym_make_nodelhs_amp,sym_make_sublhs_amp,sym==sym_dot_sub) +!!$ else +!!$ acall=merge(sym_make_nodelhs,sym_make_sublhs,sym==sym_dot_sub) +!!$ endif +!!$ endif +!!$ call make_comm_sys_call(coder,cblock,node,acall,2,1) +!!$ outmode=ior(outmode,ref_is_subscripted) +!!$ case(sym_dot) +!!$ call make_temp_var(coder,cblock,pnode) +!!$ call dup_code(coder) +!!$ outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) +!!$ call make_const(coder,cblock,node,node_arg(node,2)) +!!$ call make_basic_sp_call(coder,cblock,node,& +!!$ merge(sym_dot,sym_dot_ref,& +!!$ iand(mode,ref_is_val)/=0),2,1) +!!$ case(sym_get_dot) +!!$ call make_temp_var(coder,cblock,node) +!!$ call dup_code(coder) +!!$ outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) +!!$ call trav_expr(coder,cblock,node,node_arg(node,2)) +!!$ call make_basic_sp_call(coder,cblock,node,& +!!$ merge(sym_get_dot,sym_get_dot_ref,& +!!$ iand(mode,ref_is_val)/=0),2,1) +!!$ case(sym_get_dot_ref) +!!$ call make_temp_var(coder,cblock,node) +!!$ call dup_code(coder) +!!$ outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) +!!$ call trav_expr(coder,cblock,node,node_arg(node,2)) +!!$ call make_basic_sp_call(coder,cblock,node,& +!!$ sym_get_dot_ref,2,1) +!!$ case(sym_caret) +!!$ call trav_expr(coder,cblock,pnode,node_arg(node,1)) +!!$ case(sym_pling) +!!$ outmode=ior(trav_ref(coder,cblock,node,node_arg(node,1),mode),& +!!$ ref_has_at) +!!$ call make_comm_sys_call_rtn(coder,cblock,node,sym_make_array,1,1) +!!$ case(sym_name) +!!$ call trav_ref_to_var(coder,cblock,node,node_arg(node,1),mode) +!!$ outmode=0 +!!$ case(sym_dot_call) +!!$ outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) +!!$ call trav_exprlist(coder,cblock,node,node_arg(node,3)) +!!$ if(node_sym(node_arg(node,2))==sym_dot) then +!!$ +!!$ else +!!$ call make_comm_sys_call_rtn(coder,cblock,node,node_num_arg(node,2),& +!!$ node_numargs(node_arg(node,3))+1,1,aflags=proccall_is_ref,assign=.true.) +!!$ endif +!!$ case(sym_reference) +!!$ outmode=trav_ref(coder,cblock,node,node_arg(node,2),mode) +!!$ case default +!!$ if(iand(mode,ref_is_val)==0) then +!!$ call code_error(coder,pnode,& +!!$ 'Cannot indirectly assign to expression - value is updated') +!!$ call make_temp_var(coder,cblock,pnode) +!!$ else +!!$ call trav_expr(coder,cblock,pnode,node) +!!$ endif +!!$ end select +!!$ else +!!$ call code_error(coder,pnode,& +!!$ 'Cannot make reference') +!!$ call make_temp_var(coder,cblock,pnode) +!!$ endif +!!$ contains +!!$ include 'fvkind.inc' +!!$ include 'fisname.inc' +!!$ include 'fisnull.inc' +!!$ include 'ftiny.inc' +!!$ end function trav_ref !======================================================== ! Create a new system variable from expr on top of stack @@ -3054,15 +3002,12 @@ subroutine define_sys_var(coder,cblock,node,name,flags) type(pm_ptr),intent(in):: cblock,node integer,intent(in):: name integer,intent(in):: flags - integer:: junk type(pm_ptr):: var - write(*,*) '>>>',pm_name_as_string(coder%context,name) call make_sys_var(coder,cblock,node,name,flags) var=top_code(coder) call swap_code(coder) - call make_sys_call(coder,cblock,node,& - merge(sym_dup,sym_clone,iand(flags,var_is_var)/=0),1,1,aflags=call_ignore_rules) - call make_var_mode(coder,cblock,node,var) + call make_comm_sys_call(coder,cblock,node,& + merge(sym_make_var,sym_make_const,iand(flags,var_is_var)/=0),1,1) end subroutine define_sys_var !======================================================== @@ -3073,39 +3018,11 @@ subroutine init_var(coder,cblock,node,var) type(pm_ptr),intent(in):: cblock,node,var call code_val(coder,var) call swap_code(coder) - call make_sys_call(coder,cblock,node,& - merge(sym_dup,sym_clone,cnode_flags_set(var,var_flags,var_is_var)),& - 1,1,aflags=call_ignore_rules) - call make_var_mode(coder,cblock,node,var) + call make_comm_sys_call(coder,cblock,node,& + merge(sym_make_var,sym_make_const,cnode_flags_set(var,var_flags,var_is_var)),& + 1,1) end subroutine init_var - !======================================================== - ! Set the mode (and maybe depth) of a variable - !======================================================== - subroutine make_var_mode(coder,cblock,node,var) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node - type(pm_ptr),intent(in)::var - if(coder%run_flags==0) then - if(iand(cnode_get_num(var,var_flags),var_is_var)/=0) then - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,node,sym_private,& - 1,0,coder%par_depth) - endif - else - call code_val(coder,var) - call code_num(coder,coder%run_mode) - if(iand(coder%run_flags,proc_run_shared+proc_run_local)/=0) then - call var_set_par_depth(coder,var,coder%par_depth-1) - call make_basic_sp_call(coder,cblock,node,& - sym_var_set_mode,2,0,coder%par_depth-1) - else - call make_basic_sp_call(coder,cblock,node,& - sym_var_set_mode,2,0,coder%par_depth) - endif - endif - end subroutine make_var_mode - !======================================================== ! Assign top of stack to a given variable !======================================================== @@ -3156,7 +3073,6 @@ end subroutine trav_exprlist recursive subroutine trav_top_expr(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - integer:: save_par_state if(node_sym(node)==sym_open) then call make_temp_var(coder,cblock,pnode) call dup_code(coder) @@ -3188,10 +3104,10 @@ end subroutine trav_closed_expr recursive subroutine trav_expr(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - integer:: sym,i,n,m,nsym,base,flags,outmode - logical:: outer,shared,isproc,ischan,save_fixed - type(pm_ptr):: list,name,p,q,save_sub_array - integer:: save_par_state,loop_flags + integer:: sym,i,n,base,outmode + logical:: save_fixed + type(pm_ptr):: list,p,q + integer:: loop_flags sym=node_sym(node) loop_flags=0 @@ -3211,25 +3127,25 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) case(sym_null) call make_const(coder,cblock,pnode,pm_null_obj,int(pm_null)) case(sym_dotdotdot,sym_name,sym_use) - call trav_name(coder,cblock,node,sym,node_arg(node,1)) + call trav_name(coder,cblock,node,sym,node_num_arg(node,1)) case(sym_proc) call proc_const(coder,cblock,pnode,node) case(sym_param) if(node_numargs(node)==2) then - p=find_param(coder,cblock,node,node_arg(node,1),& - node_arg(node,2)) + p=find_param(coder,cblock,node,node_num_arg(node,1),& + node_num_arg(node,2)) if(pm_fast_isnull(p)) then call code_error(coder,node,'Cannot find parameter: ',& - node_arg(node,1)) + node_num_arg(node,1)) call make_temp_var(coder,cblock,node) else call code_val(coder,p) endif else - p=find_param(coder,cblock,node,node_arg(node,1)) + p=find_param(coder,cblock,node,node_num_arg(node,1)) if(pm_fast_isnull(p)) then call code_error(coder,node,& - 'Cannot find parameter: ',node_arg(node,1)) + 'Cannot find parameter: ',node_num_arg(node,1)) call make_temp_var(coder,cblock,node) else call code_val(coder,p) @@ -3239,21 +3155,19 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call name_const(node,sym_stretch_dim) return case(sym_unique) - p=node_arg(node,1) - call name_const(node,int(p%offset)) + call name_const(node,node_num_arg(node,1)) return - case(sym_fix) + case(sym_fix,sym_literal) save_fixed=coder%fixed coder%fixed=.true. call trav_expr(coder,cblock,node,node_arg(node,1)) coder%fixed=save_fixed - call make_sp_call_rtn(coder,cblock,node,sym_dash,1,1) + call make_sp_call_rtn(coder,cblock,node,sym,1,1) case(sym_present) - p=node_arg(node,1) - i=p%offset + i=node_num_arg(node,1) i=find_var_entry(coder,i,coder%proc_base) if(i==0) then - call code_error(coder,node,'Variable undefined in "present": ',p) + call code_error(coder,node,'Object undefined in "present": ',i) call make_temp_var(coder,cblock,node) else q=coder%var(i) @@ -3262,18 +3176,32 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call make_sp_call_rtn(coder,cblock,node,sym_present,1,1) else call code_error(coder,node,& - 'Not a keyword argument in "present": ',p) + '"present" applied to an object that is not a keyword argument: ',i) call make_temp_var(coder,cblock,node) endif endif - case(first_operator:last_operator) - do i=1,node_numargs(node) + case(first_operator:first_non_idx_operator-1) + n=node_numargs(node) + do i=1,n + call trav_expr(coder,cblock,& + node,node_arg(node,i)) + enddo + if(check_args_for_chan(n)) then + call make_comm_sys_call_rtn(coder,cblock,node,& + sym,n,1) + else + call make_sys_call_rtn(coder,cblock,node,& + sym,n,1) + endif + case(first_non_idx_operator:last_operator) + n=node_numargs(node) + do i=1,n call trav_expr(coder,cblock,& node,node_arg(node,i)) enddo call make_sys_call_rtn(coder,cblock,node,& - sym,node_numargs(node),1) - case(sym_open_smiley) + sym,n,1) + case(sym_pm_list) call make_temp_var(coder,cblock,node) call dup_code(coder) do i=1,node_numargs(node) @@ -3281,7 +3209,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) node,node_arg(node,i)) enddo call make_sp_call(coder,cblock,node,& - sym_open_smiley,node_numargs(node),1) + sym_pm_list,node_numargs(node),1) case(sym_if_expr) do i=1,node_numargs(node) call trav_expr(coder,cblock,& @@ -3320,15 +3248,9 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call make_sys_call(coder,cblock,node,sym_if_expr,3,1) enddo case(sym_uhash,sym_ustar) - if(coder%par_state>par_state_outer) then - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_comm_sys_call_rtn(coder,cblock,node,& - merge(sym_hash,sym_mult,sym==sym_uhash),1,1) - else - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call_rtn(coder,cblock,node,& - merge(sym_hash,sym_mult,sym==sym_uhash),1,1) - endif + call trav_expr(coder,cblock,node,node_arg(node,1)) + call make_comm_sys_call_rtn(coder,cblock,node,& + merge(sym_hash,sym_mult,sym==sym_uhash),1,1) case(sym_lt) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,1)) @@ -3342,55 +3264,10 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call trav_expr(coder,cblock,node,node_arg(node,i)) enddo call make_sp_call_rtn(coder,cblock,node,sym,node_numargs(node),1) - case(sym_caret) - if(node_numargs(node)==1) then - outmode=trav_ref(coder,cblock,pnode,node,0) - elseif(.not.pm_fast_isnull(node_arg(node,2))) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call code_val(coder,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,sym_change_mode,2,1,coder%par_depth) - else - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_var(coder,cblock,node,pm_fast_name(coder%context,sym_caret),& - var_is_shadowed+var_is_no_import_export,pop_code(coder)) - endif - case(sym_dcaret) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sp_call_rtn(coder,cblock,node,sym_dcaret,1,1) - case(sym_dot) - if(node_sym(node_arg(node,1))==sym_name) then - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_const(coder,cblock,node,node_arg(node,2)) - call make_sp_call_rtn(coder,cblock,node,sym_dot,2,1) - else - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - if(coder%par_state>par_state_outer) then - p=pop_code(coder) - call code_val(coder,p) - call make_static_bool_const(coder,cblock,node,iand(outmode,ref_has_at)/=0) - call make_comm_sys_call_rtn(coder,cblock,node,sym_get_ref,2,1) - call check_par_context(coder,cblock,node,.true.) - else - call make_sys_call_rtn(coder,cblock,node,sym_get_val_ref,1,1) - endif - endif - case(sym_get_dot_ref) - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - case(sym_get_dot,sym_sub,sym_dot_sub,sym_dot_call) - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - if(coder%par_state>par_state_outer) then - p=pop_code(coder) - call code_val(coder,p) - call make_static_bool_const(coder,cblock,node,iand(outmode,ref_has_at)/=0) - call make_comm_sys_call_rtn(coder,cblock,node,sym_get_ref,2,1) - call check_par_context(coder,cblock,node,.true.) - else - call make_sys_call_rtn(coder,cblock,node,sym_get_val_ref,1,1) - endif - case(sym_pling) - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) + case(sym_pm_each_index) + call trav_pm_each_index(coder,cblock,pnode,node,.true.) + case(sym_reference) + call trav_ref(coder,cblock,pnode,node,.false.,call_sym=sym_get_ref) case(sym_open) call make_temp_var(coder,cblock,node) call dup_code(coder) @@ -3426,41 +3303,17 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call trav_expr(coder,cblock,list,node_arg(list,i)) call make_assign_call(coder,cblock,list,sym_set_elem,3,0,aflags=call_ignore_rules) enddo - case(sym_struct,sym_rec) - call trav_structrec(coder,cblock,node) + case(sym_rec) + call trav_rec(coder,cblock,node) case(sym_query) - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot use "?" or "??" outside of any parallel statement') - elseif(coder%par_statepar_state_outer)) - else - call code_val(coder,p) - endif + call code_val(coder,p) endif endif @@ -3584,17 +3438,17 @@ subroutine trav_name(coder,cblock,node,sym,name) end subroutine trav_name !======================================================== - ! Traverse struct or rec creation "new" expression + ! Traverse "rec" expression ! Parse node contains full_type/ list_of_expr / name / tag !======================================================== - recursive subroutine trav_structrec(coder,cblock,node) + recursive subroutine trav_rec(coder,cblock,node) type(code_state):: coder type(pm_ptr),intent(in):: cblock,node - type(pm_ptr):: exprs,p,name,decl,tag,name1,name2,elems,info - integer:: i,j,k,vbase,n,m,count,nam1,nam2,sym,basex,tno + type(pm_ptr):: exprs,p,decl,tag,name1,name2,elems,info + integer:: i,j,k,name,vbase,n,m,count,nam1,nam2,sym,basex,tno ! Find associated type declaraton (decl) - name=node_arg(node,4) + name=node_num_arg(node,4) tag=node_arg(node,3) decl=find_decl(coder,node,name,modl_type) if(pm_fast_isnull(decl)) then @@ -3604,14 +3458,14 @@ recursive subroutine trav_structrec(coder,cblock,node) else decl=node_arg(decl,2) if(node_sym(decl)/=sym_is) then - call code_error(coder,node,'Not a "struct" or "rec" type name:',name) + call code_error(coder,node,'Not a "rec" type name:',name) call make_temp_var(coder,cblock,node) return else decl=node_arg(node_get(decl,type_includes),1) sym=node_sym(decl) - if(sym/=sym_struct.and.sym/=sym_rec) then - call code_error(coder,node,'Does not reference "struct" or "rec" type') + if(sym/=sym_rec) then + call code_error(coder,node,'Does not reference "rec" type') call code_error(coder,decl,'Declaration referenced in above error') call make_temp_var(coder,cblock,node) return @@ -3629,9 +3483,9 @@ recursive subroutine trav_structrec(coder,cblock,node) call trav_expr(coder,cblock,exprs,node_arg(node_arg(exprs,i),1)) enddo - ! Set up struct/rec creation call + ! Set up rec creation call basex=coder%vtop - info=trav_structrec_decl(coder,decl,decl) + info=trav_rec_decl(coder,decl,decl) call make_const(coder,cblock,node,info) if(pm_fast_isnull(node_arg(node,1))) then call code_num(coder,-1) @@ -3642,7 +3496,7 @@ recursive subroutine trav_structrec(coder,cblock,node) tno=pm_user_type_body(coder%context,top_word(coder)) call code_num(coder,pop_word(coder)) endif - ! At this point tno contains the body of the struct/rec type + ! At this point tno contains the body of the rec type ! Match element names and push values in correct order name1=pm_name_val(coder%context,int(tag%offset)) @@ -3685,10 +3539,10 @@ recursive subroutine trav_structrec(coder,cblock,node) if(pm_debug_checks) then if(coder%vtop/=basex+n+2) then write(*,*) '>>',coder%vtop,n,coder%vtop-n-2 - call pm_panic('trav_structrec') + call pm_panic('trav_rec') endif endif - call make_sp_call_rtn(coder,cblock,node,sym,n+2,1,flags=coder%run_flags) + call make_sp_call_rtn(coder,cblock,node,sym,n+2,1) coder%vstack(vbase+1)=coder%vstack(coder%vtop) coder%vtop=vbase+1 @@ -3698,10 +3552,12 @@ recursive subroutine trav_structrec(coder,cblock,node) include 'ftiny.inc' subroutine element_error(node,sym,name,name1,i) - type(pm_ptr),intent(in):: node,name,name1 + type(pm_ptr),intent(in):: node + integer,intent(in):: name + type(pm_ptr),intent(in):: name1 integer,intent(in):: sym,i call code_error(coder,node_arg(node,i),'"'//trim(sym_names(sym))//' '//& - trim(pm_name_as_string(coder%context,int(name%offset)))//& + trim(pm_name_as_string(coder%context,name))//& '" does not have element "'//& trim(pm_name_as_string(coder%context,& name1%data%i(name1%offset+i)))//'"') @@ -3715,7 +3571,7 @@ subroutine cast_element(node,tno) !endif end subroutine cast_element - end subroutine trav_structrec + end subroutine trav_rec !======================================================== ! Traverse a cast to a type defined by node @@ -3725,7 +3581,6 @@ recursive subroutine trav_cast(coder,cblock,pnode,node,sym) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: sym - integer:: mode,depth,tno call trav_type_constraint(coder,pnode,node) if(top_word(coder)/=0) then call make_cast(coder,cblock,node,pop_word(coder)) @@ -3747,36 +3602,9 @@ recursive subroutine make_cast(coder,cblock,node,tno) pm_fast_tinyint(coder%context,tno),int(pm_tiny_int)) call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) call make_sys_call_rtn(coder,cblock,node,sym_as,2,1) - contains - include 'ftiny.inc' - end subroutine make_cast - - !======================================================== - ! Parallel scope depth of a value - !======================================================== - function par_depth(coder,val) result(depth) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: val - integer:: depth - depth=max(1,coder%par_depth-1) - if(pm_fast_vkind(val)==pm_pointer) then - if(cnode_get_kind(val)==cnode_is_var) then - depth=cnode_get_num(val,var_par_depth)+coder%proc_par_depth - endif - endif - contains - include 'fvkind.inc' - end function par_depth - - !======================================================== - ! Set a variable to be shared - !======================================================== - subroutine set_var_as_shared(coder,var) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - call cnode_set_num(var,var_par_depth,& - coder%par_depth-1-coder%proc_par_depth) - end subroutine set_var_as_shared + contains + include 'ftiny.inc' + end subroutine make_cast !************************************************* @@ -3804,10 +3632,9 @@ end subroutine trav_type_constraint recursive subroutine trav_type(coder,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: pnode,node - integer:: sym,i,n,m,nshared,base,flags + integer:: sym,i,n,flags integer::typno type(pm_ptr):: name,val,p - character(len=100):: str if(pm_fast_isnull(node)) then call push_word(coder,0) return @@ -3862,17 +3689,17 @@ recursive subroutine trav_type(coder,pnode,node) call make_type(coder,4) case(sym_proc) if(node_numargs(node)==1) then - p=find_decl(coder,node,node_arg(node,1),modl_proc) + p=find_decl(coder,node,node_num_arg(node,1),modl_proc) if(pm_fast_isnull(p)) then call code_error(coder,node,& 'proc value not associated with any defined procedure: ',& - node_arg(node,1)) + node_num_arg(node,1)) call push_word(coder,0) return endif elseif(node_numargs(node)==2) then - p=find_imported_decl(coder,node,node_arg(node,1),& - node_arg(node,2),modl_proc) + p=find_imported_decl(coder,node,node_num_arg(node,1),& + node_num_arg(node,2),modl_proc) if(pm_fast_isnull(p)) then call push_word(coder,0) return @@ -3883,8 +3710,7 @@ recursive subroutine trav_type(coder,pnode,node) endif call push_word(coder,proc_type_from_decl(coder,p,node)) case(sym_unique) - name=node_arg(node,1) - call push_word(coder,pm_new_name_type(coder%context,int(name%offset))) + call push_word(coder,pm_new_name_type(coder%context,node_num_arg(node,1))) case(sym_fix) name=node_arg(node,1) select case(node_sym(name)) @@ -3893,7 +3719,7 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_false) call push_word(coder,coder%false_fix) case(sym_number,sym_string) - call push_word(coder,pm_new_fix_type(coder%context,node_arg(name,1))) + call push_word(coder,pm_new_fix_value_type(coder%context,node_arg(name,1))) case default call push_word(coder,pm_type_new_fix) call push_word(coder,0) @@ -3908,7 +3734,7 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_false) call push_word(coder,coder%false_literal) case(sym_number,sym_string) - call push_word(coder,pm_new_literal_type(coder%context,name)) + call push_word(coder,pm_new_literal_value_type(coder%context,name)) case default call push_word(coder,pm_type_new_unfixed) call push_word(coder,0) @@ -3946,20 +3772,15 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,0) call make_type(coder,3) case(sym_open_brace) - name=node_arg(node,1) call push_word(coder,pm_type_new_user) - call push_word(coder,int(name%offset)) + call push_word(coder,node_num_arg(node,1)) typno=get_typeno(2) if(typno==0) call pm_panic('Intrinsic type not found') call push_word(coder,typno) - case(sym_struct,sym_rec) + case(sym_rec) flags=node_num_arg(node,7) name=node_arg(node,2) - if(sym==sym_struct) then - call push_word(coder,pm_type_new_struct+flags) - else - call push_word(coder,pm_type_new_rec+flags) - endif + call push_word(coder,pm_type_new_rec+flags) call push_word(coder,abs(int(name%offset))) val=node_arg(node,1) n=node_numargs(val) @@ -3988,30 +3809,24 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) - case(sym_list,sym_dotdotdot,sym_open_smiley) - if(sym==sym_open_smiley) then - p=node_arg(node,1) - sym=node_sym(p) - i=pm_type_is_list - m=1 - else - p=node - i=0 - m=2 - endif + case(sym_list,sym_dotdotdot) if(sym==sym_dotdotdot) then - call push_word(coder,pm_type_new_vtuple+i) + call push_word(coder,pm_type_new_vtuple) else - call push_word(coder,pm_type_new_tuple+i) + call push_word(coder,pm_type_new_tuple) endif call push_word(coder,0) - nshared=0 - n=node_numargs(p) - do i=m,n,m - val=node_arg(p,i) + n=node_numargs(node) + do i=1,n,2 + val=node_arg(node,i) call trav_type(coder,val,val) enddo - call make_type(coder,n/m+2) + call make_type(coder,n/2+2) + case(sym_pm_list) + call push_word(coder,pm_type_new_vtuple+pm_type_is_list) + call push_word(coder,0) + call push_word(coder,0) + call make_type(coder,3) case(sym_assign,sym_var) call trav_type(coder,pnode,node_arg(node,1)) case(sym_pm_dref) @@ -4085,9 +3900,9 @@ recursive subroutine proc_type base=coder%wtop dp=node_arg(node,1) do i=1,node_numargs(dp),2 - if(.not.pm_fast_isnull(find_type_var(coder,node_arg(dp,i)))) then + if(.not.pm_fast_isnull(find_type_var(coder,node_num_arg(dp,i)))) then call code_error(coder,node,& - 'Cannot shadow type-match parameter:',node_arg(dp,i)) + 'Cannot shadow type-match parameter:',node_num_arg(dp,i)) endif enddo call push_word(coder,pm_type_new_proc_sig) @@ -4126,23 +3941,20 @@ end subroutine trav_type recursive subroutine trav_type_decl(coder,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: pnode,node - type(pm_ptr):: namenode,name,decl,dec,inc,pargs,also_dec - type(pm_ptr):: twice_dec,main_dec,tname,tval,pars,newdec - type(pm_ptr),target:: incset + type(pm_ptr):: namenode,decl,dec,inc,pargs,also_dec + type(pm_ptr):: twice_dec,main_dec,pars,newdec logical:: is_present,also_present,type_present logical:: dotdotdot_present,multiple_modules,twice,has_constraints - integer:: nargs,sym,i,j,n,base,parbase,ibase,npars,idepth - integer:: new_type,tno - type(pm_reg),pointer:: reg - logical:: ok + integer:: name,nargs,sym,i,base,parbase,ibase,npars,idepth + integer:: new_type ! Type name and arguments nargs=node_numargs(node)-1 namenode=node_arg(node,nargs+1) if(pm_fast_isname(namenode)) then - name=namenode + name=namenode%offset else - name=node_arg(namenode,2) + name=node_num_arg(namenode,2) endif call push_word(coder,pm_type_new_user) call push_word(coder,-1) @@ -4156,7 +3968,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Debugging stuff if(debug_codegen) then write(*,*) 'Traverse type def: ',& - trim(pm_name_as_string(coder%context,int(name%offset))),' nargs=',nargs,'{' + trim(pm_name_as_string(coder%context,name)),' nargs=',nargs,'{' do i=coder%wtop-nargs+1,coder%wtop write(*,*) coder%wstack(i) enddo @@ -4178,19 +3990,19 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Find declaration if(.not.pm_fast_isname(namenode)) then decl=find_imported_decl(coder,namenode,& - node_arg(namenode,1),node_arg(namenode,2),modl_type) + node_num_arg(namenode,1),node_num_arg(namenode,2),modl_type) if(pm_fast_isnull(decl)) then call code_error(coder,node,& 'Cannot find type: '//& trim(pm_name_as_string(coder%context,node_num_arg(namenode,1)))//'::'//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) goto 888 endif else decl=find_decl(coder,node,name,modl_type) if(pm_fast_isnull(decl)) then ! Not found but may be intrinsic declaration - coder%wstack(coder%wtop-nargs)=name%offset + coder%wstack(coder%wtop-nargs)=name new_type=get_typeno(nargs+2) if(new_type>0) then ! .. is intrinsic declaraton, return it @@ -4200,7 +4012,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif call code_error(coder,node,& 'Cannot find type: '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) goto 888 endif endif @@ -4225,7 +4037,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) call code_error(coder,decl,& 'Very complex recursive type - most probably infinite: '& //trim(pm_name_as_string(coder%context,& - int(name%offset)))) + name))) call node_set_num(decl,node_args+4,idepth+1) endif coder%wtop=coder%wtop-nargs-1 @@ -4247,7 +4059,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) parbase=coder%wtop pars=node_get(dec,type_params) npars=node_numargs(pars)/2 - call make_type_vars(coder,int(name%offset),dec,node,pars,& + call make_type_vars(coder,name,dec,node,pars,& base-nargs,nargs) inc=node_get(dec,type_parents) if(.not.pm_fast_isnull(inc)) then @@ -4292,7 +4104,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(pm_fast_isnull(dec)) then call code_error(coder,decl,& 'Type is extended using ":" or "..." but not defined: '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) goto 999 endif enddo @@ -4313,7 +4125,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) write(*,*) 'CHECK TYPE DEF>',sym_names(sym) endif if(sym==sym_in) then - call make_type_vars(coder,int(name%offset),pnode,node,& + call make_type_vars(coder,name,pnode,node,& pm_null_obj,0,0) call trav_type(coder,pnode,node_arg(dec,2)) call pop_type_vars(coder) @@ -4336,7 +4148,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) also_present=.true. also_dec=dec pargs=node_get(dec,type_params) - call make_type_vars(coder,int(name%offset),& + call make_type_vars(coder,name,& pnode,node,pargs,base-nargs,nargs,& parbase,npars) inc=node_get(dec,type_includes) @@ -4372,7 +4184,6 @@ recursive subroutine trav_type_decl(coder,pnode,node) type_present=.true. endif - 20 continue newdec=node_get(dec,type_link) endif if(pm_fast_isnull(newdec)) exit @@ -4408,20 +4219,20 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(is_present.and.also_present) then call code_error(coder,also_dec,& 'Cannot add to this type using ":" or "...": '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) call code_error(coder,main_dec,& 'Type declaration being extended in the above error') endif if(also_present.and..not.type_present) then call code_error(coder,also_dec,& '"Type extended using "..." or ":" without original "type is " definition present: '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) endif if(multiple_modules.and.also_present.and..not.dotdotdot_present) then call code_error(coder,also_dec,& 'Type is extended using "..." or ":" across multiple modules"//& " without "..." present in original "type is": '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) endif if(twice) then call code_error(coder,main_dec,& @@ -4432,7 +4243,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(debug_codegen) then write(*,*) 'definition traversed for ',& - trim(pm_name_as_string(coder%context,int(name%offset))),'#',top_word(coder) + trim(pm_name_as_string(coder%context,name)),'#',top_word(coder) write(*,*) '#', trim(pm_type_as_string(coder%context,top_word(coder))) endif @@ -4484,9 +4295,9 @@ end subroutine trav_type_decl !=============================================================== - ! Create a template type from struct/rec declaration + ! Create a template type from rec declaration !=============================================================== - recursive function trav_structrec_decl(coder,pnode,decl) result(vect) + recursive function trav_rec_decl(coder,pnode,decl) result(vect) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: decl,pnode type(pm_ptr):: vect @@ -4544,7 +4355,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) contains include 'fisnull.inc' include 'fnewnc.inc' - end function trav_structrec_decl + end function trav_rec_decl !=========================================================== ! Push information on arguments to parameterised type @@ -4558,13 +4369,11 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& integer,intent(in):: argbase,nargs integer,intent(in),optional:: parbase integer,intent(in),optional:: nbasepars - logical:: ok integer:: k,base,wbase,npars - integer:: vtyp,partyp - type(pm_ptr):: pname,tv,name - logical:: local,check_against_base + integer:: vtyp,partyp,name,pname + logical:: check_against_base check_against_base=.false. - name=node_arg(callnode,node_numargs(callnode)) + name=node_num_arg(callnode,node_numargs(callnode)) if(pm_fast_isnull(pnames)) then if(nargs/=0) then call code_error(coder,callnode,& @@ -4593,7 +4402,6 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& coder%top=coder%top+1 coder%stack(coder%top)=typevar_start coder%var(coder%top)=pm_null_obj - coder%imps(coder%top)=0 base=coder%top wbase=coder%wtop @@ -4603,8 +4411,8 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& enddo endif do k=npars,1,-1 - pname=node_arg(pnames,k*2-1) - coder%stack(k+coder%top+1)=pname%offset + pname=node_num_arg(pnames,k*2-1) + coder%stack(k+coder%top+1)=pname if(k>nargs) then vtyp=0 else @@ -4623,7 +4431,7 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& ! Defer test that parameter conforms to ! parameter in base definition call defer_type_check(coder,pnames,pnode,coder%wstack(parbase+k),& - partyp,int(pname%offset),cnode_is_par_constraint) + partyp,pname,cnode_is_par_constraint) ! Intersect argument and parameter call push_word(coder,pm_type_new_all) @@ -4642,17 +4450,16 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& else ! Defer test that argument meets parameter constraint call defer_type_check(coder,callnode,pnode,& - partyp,vtyp,int(pname%offset),cnode_is_arg_constraint) + partyp,vtyp,pname,cnode_is_arg_constraint) endif endif - if(find_var_entry(coder,& - int(pname%offset),base)>0) then + if(find_var_entry(coder,pname,base)>0) then call code_error(coder,pnames,& 'Repitition of type parameter name:',& pname) else - call push_var(coder,int(pname%offset),& + call push_var(coder,pname,& pm_fast_tinyint(coder%context,vtyp)) endif @@ -4660,7 +4467,6 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& coder%top=coder%top+1 coder%stack(coder%top)=typevar_end coder%var(coder%top)%offset=base - coder%imps(coder%top)=0 contains include 'ftiny.inc' include 'fisnull.inc' @@ -4698,7 +4504,6 @@ subroutine copy_type_vars(coder) nbase=coder%top coder%stack(coder%top)=typevar_start coder%var(coder%top)=pm_null_obj - coder%imps(coder%top)=0 do i=base+1,top-1 if(coder%stack(i)/=0) then call push_var(coder,coder%stack(i),coder%var(i)) @@ -4707,7 +4512,6 @@ subroutine copy_type_vars(coder) coder%top=coder%top+1 coder%stack(coder%top)=typevar_end coder%var(coder%top)%offset=nbase - coder%imps(coder%top)=0 end subroutine copy_type_vars !======================================== @@ -4715,7 +4519,7 @@ end subroutine copy_type_vars !======================================== function find_type_var(coder,vname) result(vr) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: vname + integer,intent(in):: vname type(pm_ptr):: vr integer:: k integer:: n @@ -4724,7 +4528,7 @@ function find_type_var(coder,vname) result(vr) elseif(coder%stack(coder%top)/=typevar_end) then vr=pm_null_obj else - n=vname%offset + n=vname k=find_var_entry(coder,n,int(coder%var(coder%top)%offset)) if(k/=0) then vr=coder%var(k) @@ -4757,11 +4561,10 @@ end subroutine defer_type_check subroutine complete_type_checks(coder) type(code_state),intent(inout):: coder type(pm_ptr):: p,keys,vals,tv - integer(pm_ln):: i,j + integer(pm_ln):: i integer:: k integer:: tno,tno1,tno2 - type(pm_ptr):: tset,name - type(pm_type_einfo):: einfo + type(pm_ptr):: name p=coder%prog_cblock keys=pm_dict_keys(coder%context,coder%context%tcache) vals=pm_dict_vals(coder%context,coder%context%tcache) @@ -4787,12 +4590,10 @@ subroutine complete_type_checks(coder) tno=i+1 ! Check type includes its body to avoid automatic true return if(.not.pm_type_includes(coder%context,tno,& - pm_user_type_body(coder%context,tno),pm_type_incl_type,& - einfo)) then + pm_user_type_body(coder%context,tno),pm_type_incl_type)) then call code_error(coder,pm_null_obj,& 'Type is incorrectly defined: '//& trim(pm_type_as_string(coder%context,tno))) - call pm_type_error(coder%context,einfo) endif endif enddo @@ -4806,8 +4607,7 @@ subroutine complete_type_checks(coder) case(cnode_is_arg_constraint) tno1=cnode_num_arg(p,2) tno2=cnode_num_arg(p,3) - if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type)) then call cnode_error(coder,p,& 'Type argument "'//& trim(pm_name_as_string(coder%context,& @@ -4816,15 +4616,13 @@ subroutine complete_type_checks(coder) trim(pm_type_as_string(coder%context,tno1))//& ' inc '//& trim(pm_type_as_string(coder%context,tno2))) - call pm_type_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Constraint that gave rise to above error') endif case(cnode_is_par_constraint) tno1=cnode_get_num(p,cnode_args+1) tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type)) then call cnode_error(coder,p,& 'Parameter "'//& trim(pm_name_as_string(coder%context,& @@ -4833,17 +4631,14 @@ subroutine complete_type_checks(coder) trim(pm_type_as_string(coder%context,tno1))//& ' ,argument: '//& trim(pm_type_as_string(coder%context,tno2))) - call pm_type_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Constraint that gave rise to the above error') endif case(cnode_is_type_constraint) tno1=cnode_get_num(p,cnode_args+1) tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_equiv,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_equiv)) then call cnode_error(coder,p,'Type does not meet constraint:') - call pm_type_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Type constraint referenced in above error') endif @@ -4868,12 +4663,12 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: nret logical,intent(in):: amps_ok - type(pm_ptr):: list,procs,keys,keynames,sig,name,amp,prvar,proc,p,arg - integer:: flags,i,j,nargs,nkeys,ampbase,vsym,outmode,nref - integer:: depth,otop,obase,owbase,base,abase,atop,babase,astart - logical:: iscomm,outer,has_shared_amp_arg,need_alias_checks,shared_ref_ok - integer:: save_run_mode,save_run_flags + type(pm_ptr):: list,procs,keys,keynames,name,amp,amps,prvar,proc + integer:: flags,i,nargs,nkeys,vsym,outmode + integer:: otop,obase,owbase,base + logical:: iscomm,isdot + ! Save stack tops to check clean up otop=coder%top obase=coder%vtop owbase=coder%wtop @@ -4890,6 +4685,7 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif nargs=node_numargs(list) iscomm=iand(flags,proccall_is_comm)/=0 + isdot=iand(flags,proccall_is_ref)/=0 if(debug_codegen) then write(*,*) 'TRAV CALL>',& @@ -4897,8 +4693,13 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) nargs,nret,coder%vtop,flags endif + if(coder%par_state==par_state_none.and.& + iscomm.and.iand(flags,proccall_is_general)==0) then + call code_error(coder,node,& + 'Cannot call a "%" procedure outside of a parallel context: ',int(name%offset)) + endif + base=coder%vtop - has_shared_amp_arg=.false. ! write(*,*) 'AMP',pm_fast_isnull(amp),trim(pm_name_as_string(coder%context,int(name%offset))) @@ -4909,50 +4710,21 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) node_arg(list,i)) enddo else - if(.not.amps_ok) then - call code_error(coder,list,& - 'Call using "&" arguments cannot be a component of an expression') - endif - - amp=pm_name_val(coder%context,int(amp%offset)) + amps=pm_name_val(coder%context,int(amp%offset)) flags=ior(flags,call_is_assign_call) - - ! Alias checks if needed - nref=0 - abase=coder%top - if(pm_opts%check_alias) then - do j=0,pm_fast_esize(amp) - i=amp%data%i(amp%offset+j) - arg=node_arg(list,i) - - !!! ampbase not set here -- and should be - call trav_alias_checks(coder,cblock,list,amp,i,ampbase) - nref=nref+1 - enddo - endif - atop=coder%top - - do i=1,nret - call code_val(coder,coder%vstack(base-nret+i)) - enddo - base=coder%vtop - j=0 - do i=1,nargs - if(amp%data%i(amp%offset+j)==i) then - arg=node_arg(list,i) - outmode=trav_ref(coder,cblock,list,& - arg,merge(ref_ignores_rules+ref_is_amp,ref_is_amp,iscomm)) - j=min(pm_fast_esize(amp),j+1) - else - arg=node_arg(list,i) - call trav_expr(coder,cblock,list,arg) + if(.not.amps_ok) then + if(iand(flags,proccall_is_yield)/=0) then + call code_error(coder,list,'"yield" cannot be a component of an expression') + elseif(iand(flags,proccall_is_ref)==0) then + call code_error(coder,list,& + 'Call using "&" arguments cannot be a component of an expression') endif - enddo - call hide_vars(coder,abase+1,atop) + endif + call process_amp_args(amps,int(pm_fast_esize(amps)+1)) endif - babase=merge(base+3,base+1,iscomm) - call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.) + ! Create argument list node from nargs + nret values on vstack + call make_arglist(coder,cblock,node,nargs,nret,.false.,iscomm,comm_args_present=.true.) ! Keyword arguments if(.not.pm_fast_isnull(keys)) then @@ -4966,42 +4738,37 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) call code_null(coder) endif - ! Find procs with this signature - amp=node_arg(node,3) + ! Find procs with this name proc=pm_null_obj if(pm_fast_isname(name)) then - proc=find_decl(coder,node,name,modl_proc) + proc=find_decl(coder,node,int(name%offset),modl_proc) if(pm_fast_isnull(proc)) then - call code_error(coder,node,'Cannot find proc: ',name) + call code_error(coder,node,'Cannot find proc: ',int(name%offset)) call make_temp_var(coder,cblock,node) endif else vsym=node_sym(name) select case(vsym) case(sym_name) - proc=find_decl(coder,name,name,modl_proc) + proc=find_decl(coder,name,node_num_arg(name,1),modl_proc) if(pm_fast_isnull(proc)) then - call code_error(coder,name,'Cannot find proc: ',node_arg(name,1)) + call code_error(coder,name,'Cannot find proc: ',node_num_arg(name,1)) endif case(sym_use) - proc=find_imported_decl(coder,name,node_arg(name,1),& - node_arg(name,2),modl_proc) + proc=find_imported_decl(coder,name,node_num_arg(name,1),& + node_num_arg(name,2),modl_proc) case(sym_dot) call trav_expr(coder,cblock,node,node_arg(name,1)) case(sym_proc) if(node_numargs(name)==1) then - proc=find_decl(coder,name,node_arg(name,1),modl_proc) + proc=find_decl(coder,name,node_num_arg(name,1),modl_proc) if(pm_fast_isnull(proc)) then - call code_error(coder,name,'Cannot find proc: ',node_arg(name,1)) + call code_error(coder,name,'Cannot find proc: ',node_num_arg(name,1)) endif else - proc=find_imported_decl(coder,name,node_arg(name,1),& - node_arg(name,2),modl_proc) + proc=find_imported_decl(coder,name,node_num_arg(name,1),& + node_num_arg(name,2),modl_proc) endif - case(sym_method_call) - call code_val(coder,coder%vstack(babase)) - call make_const(coder,cblock,node,node_arg(name,1)) - call make_sp_call_rtn(coder,cblock,node,sym_method_call,2,1) case default write(*,*) sym_names(vsym) call pm_panic('Bad VSYM in trav_call') @@ -5011,17 +4778,15 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif endif - !write(*,*) '++++>',coder%vtop,trim(pm_name_as_string(coder%context,int(name%offset))) - + ! Now find procs with this signature if(.not.pm_fast_isnull(proc)) then prvar=pm_null_obj - procs=find_sig(coder,node,name) + procs=find_sig(coder,node,name,proc) else + ! f.(...) call prvar=pop_code(coder) procs=pm_fast_tinyint(coder%context,0) endif - - !write(*,*) '++++=>',coder%vtop,trim(pm_name_as_string(coder%context,int(name%offset))) ! Error return if no such proc if(pm_fast_isnull(procs)) then @@ -5029,33 +4794,9 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) return endif -!!$ ! Keyword arguments (need sig first) -!!$ if(.not.pm_fast_isnull(prvar).and..not.pm_fast_isnull(keys)) then -!!$ call code_error(coder,keys,'Cannot have keyword arguments in ".()" call') -!!$ nkeys=0 -!!$ else -!!$ nkeys=trav_keys(coder,cblock,keys,sig,iscomm) -!!$ endif - - if(coder%par_state>=par_state_cond) then - flags=ior(flags,call_is_cond) - endif - - if(coder%par_state==par_state_cond.or.& - coder%par_state==par_state_par) then - flags=ior(flags,call_is_unlabelled) - endif - - ! Make the call - !call import_args(coder,cblock,node,nargs,nret,nkeys,amp,flags,abase) - - !write(*,*) '==>',obase,coder%vtop,nargs,nret - + ! Make the actual call node call make_full_call(coder,cblock,node,procs,amp,& - nargs,nret,nkeys,keynames,flags,prvar,coder%par_depth) - - !write(*,*) '===>',obase,coder%vtop,nargs,nret - + nargs,nret,nkeys,keynames,flags,prvar) ! If this is a variable call, flag the variable if(.not.pm_fast_isnull(prvar)) then @@ -5067,17 +4808,21 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif endif endif - - if(.not.pm_fast_isnull(amp)) coder%vtop=obase-nret - ! If debugging, check tidy up + ! If debugging compiler, check tidy up if(pm_debug_checks) then - if(coder%vtop/=obase-nret.or.coder%wtop/=owbase) then - write(*,*) obase,nret,obase-nret,coder%vtop,owbase,coder%wtop,nargs,otop,& - coder%top,pm_fast_isnull(amp),& - trim(pm_name_as_string(coder%context,int(name%offset))) - call pm_panic('trav call') + if(coder%vtop/=obase-nret) then + write(*,*) coder%vtop,'/=',obase,'-',nret + call pm_panic('trav_call vstack mismatch') + endif + if(coder%wtop/=owbase) then + write(*,*) coder%wtop,'/=',owbase + call pm_panic('trav_call wstack mismatch') endif +!!$ if(coder%top/=otop) then +!!$ write(*,*) coder%top,'/=',otop +!!$ call pm_panic('trav_call local stack mismatch') +!!$ endif endif if(debug_codegen) then @@ -5092,8 +4837,74 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) include 'fesize.inc' include 'fvkind.inc' include 'ftiny.inc' + + ! For each & argument x, potentially aliasing argument y, code: + ! x1=PM__lhs_and_val(x) + ! PM__check_alias(x1,y1) + ! x2=PM__copy_in(x1) + ! f(...,&x2,...) + ! PM__copy_out(&x1,x2) // This is coded in post-process + ! + ! All x1 and then all x2 values are stored on vstack above base + + subroutine process_amp_args(amp,namp) + type(pm_ptr),intent(in):: amp + integer,intent(in):: namp + integer:: i,j,jj,k,sym + type(pm_ptr):: arg + + j=0 + do i=1,nargs + if(amp%data%i(amp%offset+j)==i) then + call trav_ref(coder,cblock,list,node_arg(list,i),.true.) + + ! Check for aliasing with other parameters + do k=1,i-1 + arg=node_arg(list,k) + sym=node_sym(arg) + if(sym==sym_name.or.sym==sym_reference) then + call check_alias(coder,cblock,node_arg(list,i),arg,& + '"&" argument aliases with another argument') + endif + enddo + jj=min(pm_fast_esize(amp),jj+1) + do k=i+1,nargs + if(k==amp%data%i(amp%offset+jj)) then + jj=min(pm_fast_esize(amp),jj+1) + else + arg=node_arg(list,k) + sym=node_sym(arg) + if(sym==sym_name.or.sym==sym_reference) then + call check_alias(coder,cblock,node_arg(list,i),arg,& + '"&" argument aliases with another argument') + endif + endif + enddo + + !! Find index of location of next "&" arg + j=min(pm_fast_esize(amp),j+1) + else + arg=node_arg(list,i) + call trav_expr(coder,cblock,list,arg) + endif + enddo + end subroutine process_amp_args + end subroutine trav_call + !================================================= + ! Make an alias check - PM__alias_check(p1,p2) + !================================================= + subroutine make_alias_check(coder,cblock,node,p1,p2) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + type(pm_ptr),intent(in):: p1,p2 + call dup_expr(coder,p1) + call dup_expr(coder,p2) + call make_sys_call(coder,cblock,node,sym_check_alias,2,0) + end subroutine make_alias_check + + !=============================================================== ! Traverse procedure definition !=============================================================== @@ -5102,32 +4913,22 @@ recursive subroutine trav_proc(coder,node) type(pm_ptr),intent(in):: node integer:: nargs,nret - type(pm_ptr):: cblock,cblock2,cblock3,cblock4 - type(pm_ptr):: p,par,amp,rtypes,arg,rv,keycall,argcall + type(pm_ptr):: cblock,cblock2 + type(pm_ptr):: p,amp,keycall,argcall type(pm_ptr),target:: tkeys - integer:: i,j,n,base,obase,wbase,npars,cbase - integer:: flags,sym,loop_pars,reduce_base,reduce_start,rsig - integer:: partyp - integer:: save_index,t - integer:: save_proc_base,& - save_par_base, save_over_base,save_proc_par_depth,& - save_proc_nret,save_par_state,save_proc_ncalls,& - save_subs_index,save_lex_scope,save_run_mode,save_run_flags,& + integer:: i,j,base,obase,wbase,npars,cbase + integer:: flags,sym,rsig + integer:: save_index,save_proc_base,save_proc_ncalls,& + save_lex_scope,save_par_state,& save_state_base,save_mask - type(pm_ptr):: save_sub_array,save_loop_cblock, & - save_proc_keys,save_label - logical:: save_aliased,save_in_sync integer:: pr_flags type(pm_reg),pointer:: reg - logical:: complete,old_complete integer,save:: pdepth=0 nargs=node_numargs(node_get(node,proc_params))/2 nret=node_get_num(node,proc_numret) flags=node_get_num(node,proc_flags) - !amps=node_get(node,proc_amplocs) - !keyargs=pm_null_obj if(debug_codegen) then write(*,*) repeat(' ',pdepth),'TRAV PROC>',& @@ -5179,16 +4980,12 @@ recursive subroutine trav_proc(coder,node) return endif - old_complete=coder%par_statepm_register(coder%context,'tproc',tkeys) @@ -5197,29 +4994,20 @@ recursive subroutine trav_proc(coder,node) flags=node_get_num(node,proc_flags) pr_flags=flags if(iand(flags,proccall_is_comm)/=0) then - loop_pars=coder%top -!!$ if(iand(flags,proc_run_complete)/=0) then -!!$ complete=.true. -!!$ call check_param_modes(sym_complete,sym_complete) -!!$ elseif(iand(flags,proc_is_uncond)/=0) then -!!$ complete=.true. -!!$ elseif(iand(flags,proc_is_cond)/=0) then -!!$ complete=.false. -!!$ else - complete=old_complete -!!$ endif + coder%par_state=par_state_comm_proc call code_params(cblock,.true.,argcall) - call code_keys(cblock,tkeys,keycall) - call code_loop_startup(cblock,cblock2,cblock3) - call code_check(cblock3) - call code_body(cblock3) - call code_result(cblock3,flags) - call code_loop_finish(cblock,cblock2,cblock3) + call code_keys(cblock,tkeys,keycall,.true.) + call code_loop_startup(cblock,cblock2) + call code_check(cblock2) + call code_body(cblock2) + call code_result(cblock2,flags) + call code_loop_finish(cblock,cblock2) else + coder%par_state=par_state_none call code_params(cblock,.false.,argcall) call make_state_vars(coder,cblock,node,& topo=coder%var(coder%proc_base+1)) - call code_keys(cblock,tkeys,keycall) + call code_keys(cblock,tkeys,keycall,.false.) call code_check(cblock) call code_body(cblock) call code_result(cblock,flags) @@ -5246,10 +5034,6 @@ recursive subroutine trav_proc(coder,node) call make_code(coder,node,cnode_is_proc,pr_node_size) call pm_delete_register(coder%context,reg) - -!!$ call pop_par_scope(coder,cblock,node) - - coder%par_depth=coder%par_depth-1 call restore_proc_state @@ -5287,18 +5071,7 @@ subroutine save_proc_state save_lex_scope=coder%lex_scope save_proc_base=coder%proc_base save_proc_ncalls=coder%proc_ncalls - save_par_base=coder%par_base - save_over_base=coder%over_base - save_loop_cblock=coder%loop_cblock - save_proc_par_depth=coder%proc_par_depth - save_proc_nret=coder%proc_nret save_par_state=coder%par_state - save_label=coder%label - save_subs_index=coder%subs_index - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - save_aliased=coder%aliased - save_in_sync=coder%in_sync save_state_base=coder%state_base save_mask=coder%mask end subroutine save_proc_state @@ -5308,16 +5081,6 @@ subroutine init_proc_state coder%lex_scope=0 coder%proc_base=coder%top coder%proc_ncalls=0 - coder%par_base=coder%top - coder%over_base=coder%top+2 - coder%proc_par_depth=coder%par_depth - coder%proc_nret=nret - coder%par_state=par_state_outer - coder%run_mode=sym_private - coder%subs_index=-1 - coder%run_flags=0 - coder%aliased=.false. - coder%in_sync=.false. end subroutine init_proc_state subroutine restore_proc_state @@ -5325,19 +5088,7 @@ subroutine restore_proc_state coder%lex_scope=save_lex_scope coder%proc_base=save_proc_base coder%proc_ncalls=save_proc_ncalls - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%loop_cblock=save_loop_cblock - coder%par_depth=coder%proc_par_depth - coder%proc_par_depth=save_proc_par_depth - coder%proc_nret=save_proc_nret coder%par_state=save_par_state - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - coder%label=save_label - coder%subs_index=save_subs_index - coder%aliased=save_aliased - coder%in_sync=save_in_sync coder%state_base=save_state_base coder%mask=save_mask end subroutine restore_proc_state @@ -5346,16 +5097,21 @@ subroutine code_params(cblock,iscomm,argcall) type(pm_ptr),intent(in):: cblock logical,intent(in):: iscomm type(pm_ptr),intent(out):: argcall - type(pm_ptr):: name,var,p - integer:: state,flags,cflags + type(pm_ptr):: p + integer:: name,flags,flags0 + if(iscomm) then + coder%state_base=coder%top + coder%mask=coder%state_base+num_comm_args + endif p=node_get(node,proc_params) + flags0=merge(var_is_maybe_not_private,0,iscomm) if(.not.pm_fast_isnull(p)) then amp=node_get(node,proc_amplocs) if(pm_fast_isnull(amp)) then do i=1,node_numargs(p),2 - flags=var_is_param - name=node_arg(p,i) - if(name%offset==sym_dotdotdot) flags=var_is_varg + flags=flags0+var_is_param + name=node_num_arg(p,i) + if(name==sym_dotdotdot) flags=var_is_varg call make_var(coder,cblock,p,name,flags) enddo else @@ -5363,81 +5119,37 @@ subroutine code_params(cblock,iscomm,argcall) amp=pm_name_val(coder%context,int(amp%offset)) do i=1,node_numargs(p),2 if(amp%data%i(amp%offset+j)==(i+1)/2) then - flags=var_is_ref+var_is_param+var_is_var + flags=flags0+var_is_ref+var_is_param+var_is_var if(node_sym(node_arg(p,i+1))/=sym_pm_dref) then flags=ior(flags,var_is_ref) endif if(j>" procedure must have an explicit mode') - else - if(.not.pm_mode_compatable(mode,node_num_arg(arg,2))) then - call code_error(coder,arg,& - 'Parameter for "<<'//trim(sym_names(flag_sym))//& - '>>" procedure cannot have this mode: ',node_arg(arg,2)) - endif - endif - enddo - p=node_get(node,proc_result_types) - do i=1,node_numargs(p) - arg=node_arg(p,i) - if(node_sym(arg)==sym_mode) then - call code_error(coder,node,& - 'Return modes for a "<<'//& - trim(sym_names(flag_sym))//& - '>>" procedure must be undefined or "'//& - trim(sym_names(mode))) - endif - enddo - end subroutine check_param_modes - - recursive subroutine code_keys(cblock,tkeys,key_call) + + recursive subroutine code_keys(cblock,tkeys,key_call,iscomm) type(pm_ptr),intent(in):: cblock type(pm_ptr),intent(inout):: key_call type(pm_ptr),intent(inout),target:: tkeys - type(pm_ptr):: p,vname,typ,cblock2 - integer:: i,n,base,vbase,wbase,tno + logical,intent(in):: iscomm + type(pm_ptr):: p,typ,cblock2 + integer:: i,n,base,vname,vbase,wbase,tno,flags0 + + flags0=merge(var_is_maybe_not_private,0,iscomm) p=node_get(node,proc_keys) if(pm_fast_isnull(p)) then @@ -5452,10 +5164,10 @@ recursive subroutine code_keys(cblock,tkeys,key_call) ! Create actual keyword parameter variables wbase=coder%wtop do i=1,node_numargs(p),3 - vname=node_arg(p,i) - call push_word(coder,int(vname%offset)) + vname=node_num_arg(p,i) + call push_word(coder,vname) call make_var(coder,cblock,p,vname,& - var_is_param+var_is_key+var_is_multi_access) + flags0+var_is_param+var_is_key+var_is_multi_access) enddo ! Create a vector of all key names followed by all key types @@ -5475,9 +5187,9 @@ recursive subroutine code_keys(cblock,tkeys,key_call) ! Create visible keyword parameters do i=1,node_numargs(p),3 - vname=node_arg(p,i) + vname=node_num_arg(p,i) call make_var(coder,cblock,p,vname,& - var_is_key+var_is_multi_access+var_is_shadowed,& + flags0+var_is_key+var_is_multi_access+var_is_shadowed,& extra_info=coder%var(base+(i+2)/3)) enddo @@ -5531,24 +5243,14 @@ end subroutine code_body recursive subroutine code_result(cblock,flags) type(pm_ptr),intent(in):: cblock integer,intent(in):: flags - type(pm_ptr):: p,q - integer:: status,i,j + type(pm_ptr):: p + integer:: i ! Result expression p=node_get(node,proc_result) if(.not.pm_fast_isnull(p)) then base=coder%vtop call trav_xexpr(coder,cblock,node,p) - if(iand(flags,proc_run_shared+proc_run_local)/=0) then - do i=coder%vtop+1-nret,coder%vtop - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call code_val(coder,coder%vstack(i)) - call make_basic_sp_call(coder,cblock,node,sym_import_param,1,1,& - coder%par_depth) - coder%vstack(i)=pop_code(coder) - enddo - end if call make_sp_call(coder,cblock,node,& sym_result,nret,0) rsig=pop_word(coder) @@ -5571,82 +5273,17 @@ recursive subroutine code_result(cblock,flags) end subroutine code_result ! This sets up a par-loop structure for comm proc - subroutine code_loop_startup(cblock,cblock2,cblock3) + subroutine code_loop_startup(cblock,cblock2) type(pm_ptr),intent(in):: cblock - type(pm_ptr),intent(out):: cblock2,cblock3 - integer:: iter - - cblock3=cblock - cblock2=cblock - -!!$ !coder%over_base=coder%top -!!$ call push_var(coder,sym_for,& -!!$ coder%var(loop_pars+1)) -!!$ -!!$ -!!$ call make_sys_var(coder,cblock,node,sym_in,0) -!!$ -!!$ iter=coder%top -!!$ coder%par_base=iter -!!$ call make_sys_var(coder,cblock,node,sym_pling,var_is_shadowed) -!!$ call code_val(coder,coder%var(iter+lv_distr)) -!!$ call make_sys_call(coder,cblock,node,sym_get_tile_sz,1,2) -!!$ call make_sys_var(coder,cblock,node,sym_hash,var_is_shadowed) -!!$ call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) -!!$ call drop_code(coder) -!!$ cblock2=make_cblock(coder,cblock,node,sym_proc) -!!$ coder%loop_cblock=cblock2 -!!$ call drop_code(coder) -!!$ -!!$ ! Alias the region and subregion variables -!!$ call push_var(coder,sym_region,coder%var(iter+lv_distr)) -!!$ call push_var(coder,sym_subregion,coder%var(loop_pars+2)) -!!$ coder%over_base =coder%top -!!$ -!!$ call push_par_scope(coder,cblock2) -!!$ call push_var(coder,sym_here_in_tile,coder%var(loop_pars+3)) -!!$ call make_sys_var(coder,cblock2,node,sym_here,var_is_shadowed) -!!$ call code_val(coder,coder%var(iter+lv_tile)) -!!$ call code_val(coder,coder%var(iter+lv_index)) -!!$ call make_sys_call(coder,cblock2,node,sym_get_element,2,1) -!!$ -!!$ if(iter+lv_here/=coder%top) then -!!$ write(*,*) '#',iter+lv_here,coder%top -!!$ call pm_panic('iter mismatch in code_loop_startup') -!!$ endif -!!$ -!!$ coder%par_state=par_state_for -!!$ coder%run_mode=sym_complete -!!$ -!!$ coder%par_state=merge(par_state_for,par_state_masked,complete) -!!$ -!!$ if(complete) pr_flags=ior(pr_flags,proc_run_complete) -!!$ cblock3=make_cblock(coder,cblock2,node,sym_for_stmt) -!!$ -!!$ if(pm_is_compiling) then -!!$ ! Call PM__do_over to set-up subset loops -!!$ call make_sys_var(coder,cblock3,node,sym_nested_loop,var_is_shadowed) -!!$ call dup_code(coder) -!!$ call code_val(coder,coder%var(coder%over_base)) -!!$ call code_val(coder,coder%var(iter+lv_distr)) -!!$ call make_basic_sys_call(coder,cblock3,node,sym_do_over,2,1,& -!!$ coder%par_depth-1,call_inline_when_compiling) -!!$ call make_basic_sys_call(coder,cblock3,node,sym_nested_loop,1,0,& -!!$ coder%par_depth-1,call_inline_when_compiling) -!!$ endif - + type(pm_ptr),intent(out):: cblock2 + call code_val(coder,coder%vstack(coder%state_base+4)) + cblock2=make_cblock(coder,cblock,node,sym_pct) end subroutine code_loop_startup - subroutine code_loop_finish(cblock,cblock2,cblock3) - type(pm_ptr),intent(in):: cblock,cblock2,cblock3 -!!$ call close_cblock(coder,cblock3) -!!$ call make_sp_call(coder,cblock2,node,sym_for,1,0) -!!$ call close_cblock(coder,cblock2) -!!$ call pop_par_scope(coder,cblock,node) -!!$ call code_val(coder,coder%var(coder%par_base+lv_numz)) -!!$ call code_val(coder,cblock2) -!!$ call code_val(coder,coder%var(coder%par_base+lv_num)) -!!$ call make_sp_call(coder,cblock,node,sym_pct,2,1) + subroutine code_loop_finish(cblock,cblock2) + type(pm_ptr),intent(in):: cblock,cblock2 + call close_cblock(coder,cblock2) + call make_sp_call(coder,cblock,node,sym_pct,2,0) end subroutine code_loop_finish end subroutine trav_proc @@ -5661,14 +5298,15 @@ subroutine trav_params(coder,cblock,paramlist,amps,step,pre_args) type(pm_ptr),intent(in):: cblock,paramlist integer,intent(in):: amps,step,pre_args - integer:: i,j,k,flags,nargs,name + integer:: i,j,k,flags,flags0,nargs,name type(pm_ptr):: amp + flags0=var_is_param+var_is_maybe_not_private nargs=node_numargs(paramlist) if(amps==0) then do i=1,nargs,step - flags=var_is_param + flags=flags0 name=node_num_arg(paramlist,i) - if(name==sym_dotdotdot) flags=var_is_varg + if(name==sym_dotdotdot) flags=flags0+var_is_varg call make_sys_var(coder,cblock,paramlist,name,flags) enddo else @@ -5681,15 +5319,15 @@ subroutine trav_params(coder,cblock,paramlist,amps,step,pre_args) flags=var_is_ref+var_is_param+var_is_var if(j' @@ -5985,10 +5618,8 @@ subroutine sort_sig(coder,sig,signo) if(debug_more_codegen) write(*,*) 'SIG DIFFERENT' sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 j=j+1 - else if(pm_type_includes(coder%context,typ2,typ1,pm_type_incl_type,& - einfo)) then - if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type,& - einfo)) then + else if(pm_type_includes(coder%context,typ2,typ1,pm_type_incl_type)) then + if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type)) then if(.not.pm_type_has_when(coder%context,typ2)) then call cnode_error(coder,proc1,& 'Procedure "'//trim(sig_name_str(coder,signo))//& @@ -6007,8 +5638,7 @@ subroutine sort_sig(coder,sig,signo) endif else if(debug_more_codegen) write(*,*) 'SIG NOT INCL' - if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type,& - einfo)) then + if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type)) then call check_nesting(proc2,proc1) endif sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 @@ -6049,7 +5679,7 @@ subroutine check_nesting(first,second) rtype1=pm_tv_arg(tv1,ii) rtype2=pm_tv_arg(tv2,ii) if(.not.pm_type_includes(coder%context,& - rtype1,rtype2,pm_type_incl_type,einfo)) then + rtype1,rtype2,pm_type_incl_type)) then if(.not.isbad) then call cnode_error(coder,first,& 'Procedure "'//trim(sig_name_str(coder,signo))//& @@ -6087,12 +5717,11 @@ end subroutine sort_sig !======================================================== recursive function find_param(coder,cblock,node,name,name2) result(v) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,name - type(pm_ptr),intent(in),optional:: name2 + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: name + integer,intent(in),optional:: name2 type(pm_ptr):: v type(pm_ptr):: p - logical:: ok - integer:: i,n if(present(name2)) then p=find_imported_decl(coder,node,name,name2,modl_param,.true.) else @@ -6121,15 +5750,17 @@ end function find_param !======================================================== function find_decl(coder,node,name,where) result(ptr) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node,name - integer,intent(in):: where + type(pm_ptr),intent(in):: node + integer,intent(in):: name,where type(pm_ptr):: ptr type(pm_ptr):: v,modl modl=node_get_modl(node) - v=pm_dict_lookup(coder%context,modl%data%ptr(modl%offset+where),name) + v=pm_dict_lookup(coder%context,modl%data%ptr(modl%offset+where),& + pm_fast_name(coder%context,name)) if(pm_fast_isnull(v)) then v=pm_dict_lookup(coder%context,& - modl%data%ptr(modl%offset+where+modl_local),name) + modl%data%ptr(modl%offset+where+modl_local),& + pm_fast_name(coder%context,name)) if(pm_fast_isnull(v)) then ptr=v return @@ -6138,6 +5769,7 @@ function find_decl(coder,node,name,where) result(ptr) ptr=v%data%ptr(v%offset) contains include 'fisnull.inc' + include 'fname.inc' end function find_decl !======================================================== @@ -6145,24 +5777,25 @@ end function find_decl !======================================================== function find_imported_decl(coder,node,name1,name2,where,noerr) result(p) type(code_state):: coder - type(pm_ptr),intent(in):: node,name1,name2 + type(pm_ptr),intent(in):: node + integer,intent(in):: name1,name2 integer,intent(in):: where logical,intent(in),optional:: noerr type(pm_ptr):: p - type(pm_ptr):: thismodl,modl,dict + type(pm_ptr):: thismodl,modl character(len=5):: str thismodl=node_get_modl(node) modl=pm_dict_lookup(coder%context,& thismodl%data%ptr(thismodl%offset+modl_include),& - name1) + pm_fast_name(coder%context,name1)) if(pm_fast_isnull(modl)) then call code_error(coder,node,'No such module: ',name1) p=pm_null_obj else modl=node_arg(modl,2) p=pm_dict_lookup(coder%context,& - modl%data%ptr(modl%offset+where),name2) + modl%data%ptr(modl%offset+where),pm_fast_name(coder%context,name2)) if(pm_fast_isnull(p)) then if(.not.present(noerr)) then str='proc' @@ -6172,7 +5805,7 @@ function find_imported_decl(coder,node,name1,name2,where,noerr) result(p) str='param' endif call code_error(coder,node,'Cannot find '//str//' '//& - trim(pm_name_as_string(coder%context,int(name2%offset)))//& + trim(pm_name_as_string(coder%context,name2))//& ' in: ',name1) endif else @@ -6181,25 +5814,9 @@ function find_imported_decl(coder,node,name1,name2,where,noerr) result(p) endif contains include 'fisnull.inc' + include 'fname.inc' end function find_imported_decl - - !=============================================== - ! Push two implicit communicating proc arguments - !=============================================== - subroutine make_comm_call_args(coder,cblock,node) - type(code_state),intent(inout):: coder - type(pm_ptr):: cblock,node - if(coder%par_base==0) then - call make_temp_var(coder,cblock,node) - call make_temp_var(coder,cblock,node) - call make_temp_var(coder,cblock,node) - else - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(coder%par_base+lv_index)) - endif - end subroutine make_comm_call_args !======================================================================= ! Make type using size elements from wstack and push it on wstack @@ -6255,87 +5872,24 @@ function make_user_type(coder,n,tno) result(new_type) end function make_user_type - - !========================================== - ! Set the parallel depth of a variable - !========================================== - subroutine var_set_par_depth(coder,var,depth) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - integer:: depth - call cnode_set_num(var,var_par_depth,depth-coder%proc_par_depth) - end subroutine var_set_par_depth - - !===================================================== - ! Check if a variable is local to the current loop - !===================================================== - function var_private(coder,var) result(islocal) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical:: islocal - islocal=.false. - if(pm_fast_vkind(var)==pm_pointer) then - if(cnode_get_kind(var)==cnode_is_var) then - islocal=cnode_get_num(var,var_par_depth)==& - coder%par_depth-coder%proc_par_depth - endif - endif - contains - include 'fvkind.inc' - end function var_private - - !================================ - ! Is value shared? - !================================ - function var_shared(coder,var) result(isshared) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical:: isshared - integer:: depth - isshared=.true. - if(pm_fast_vkind(var)==pm_pointer) then - if(cnode_get_kind(var)==cnode_is_var) then - depth=cnode_get_num(var,var_par_depth) - isshared=depth<=coder%par_depth-1-coder%proc_par_depth - endif - endif - contains - include 'fvkind.inc' - end function var_shared - - !============================================================================= - ! Check if a variable was created in parallel scope containing current loop - !============================================================================= - function var_outer(coder,var) result(isouter) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical:: isouter - isouter=.false. - if(pm_fast_vkind(var)==pm_pointer) then - if(cnode_get_kind(var)==cnode_is_var) then - isouter=cnode_get_num(var,var_par_depth)==& - coder%par_depth-1-coder%proc_par_depth - endif - endif - contains - include 'fvkind.inc' - end function var_outer - !=================================== ! Find a variable !=================================== function find_var(coder,name) result(v) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: name + integer,intent(in):: name type(pm_ptr):: v integer:: i integer::n - n=name%offset - i=find_var_entry(coder,n,coder%proc_base) + i=find_var_entry(coder,name,coder%proc_base) if(i/=0) then v=coder%var(i) if(i<=coder%block_base) then + if(debug_more_codegen) then + write(*,*) 'importing>',trim(pm_name_as_string(coder%context,n)) + endif call import_to_block_scope(coder,i,v,coder%block_entry) + coder%var(i)=v endif else v=pm_null_obj @@ -6343,21 +5897,48 @@ function find_var(coder,name) result(v) return end function find_var + !========================================= + ! Find a system variable which must exist + !========================================== + function find_sys_var(coder,node,name) result(v) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + integer,intent(in):: name + type(pm_ptr):: v + integer::i + v=find_var(coder,name) + if(pm_debug_checks) then + if(pm_fast_isnull(v)) then + call code_error(coder,node,'Internal_error - cannot find sys var: '//& + trim(pm_name_as_string(coder%context,name))) + do i=1,coder%top + write(*,*) '>>',trim(pm_name_as_string(coder%context,coder%stack(i))) + enddo + call pm_panic('ooo') + endif + endif + contains + include 'fname.inc' + include 'fisnull.inc' + end function find_sys_var + + !========================================== ! Find a variable and its table entry !========================================== function find_var_and_entry(coder,name,i) result(v) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: name + integer,intent(in):: name integer,intent(out):: i type(pm_ptr):: v integer::n - n=name%offset + n=name i=find_var_entry(coder,n,coder%proc_base) if(i/=0) then v=coder%var(i) if(i<=coder%block_base) then call import_to_block_scope(coder,i,v,coder%block_entry) + coder%var(i)=v endif else v=pm_null_obj @@ -6374,8 +5955,6 @@ function find_var_entry(coder,n,base) result(index) integer,intent(in):: base integer:: index integer:: i - type(pm_ptr):: node - index=0 do i=coder%top,base+1,-1 if(coder%stack(i)==n) then @@ -6421,20 +6000,10 @@ subroutine make_temp_var(coder,cblock,node) call code_val(coder,cblock) call code_null(coder) flags=0 - if(coder%par_state>=par_state_cond) then - flags=ior(flags,var_is_incomplete) - endif - if(coder%par_state==par_state_par) then - flags=ior(flags,var_is_par_var) - endif call code_num(coder,flags) call code_null(coder) coder%index=coder%index+1 call code_num(coder,coder%index) - call code_val(coder,& - pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) - call code_val(coder,& - pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) call code_num(coder,coder%lex_scope) call make_code(coder,node,cnode_is_var,var_node_size) link=cnode_get(cblock,cblock_last_var) @@ -6466,8 +6035,7 @@ subroutine make_sys_var(coder,cblock,node,name,flags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: name,flags - call make_var(coder,cblock,node,& - pm_fast_name(coder%context,name),flags) + call make_var(coder,cblock,node,name,flags) contains include 'fname.inc' end subroutine make_sys_var @@ -6477,19 +6045,19 @@ end subroutine make_sys_var !==================================== subroutine make_var(coder,cblocka,node,name,flags,extra_info) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblocka,node,name - integer,intent(in):: flags + type(pm_ptr),intent(in):: cblocka,node + integer,intent(in):: name,flags type(pm_ptr),optional:: extra_info type(pm_ptr):: var,link,cblock - logical:: local integer:: vflags + ! Check for prior definition if(iand(flags,var_is_shadowed+var_is_imported)==0) then var=find_var(coder,name) if(.not.pm_fast_isnull(var)) then if(pm_debug_checks) then - if(name%offset==0) call pm_panic('null name in make_var') + if(name==0) call pm_panic('null name in make_var') endif call code_error(coder,node,& 'Cannot redefine local variable or constant:',name) @@ -6507,26 +6075,16 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) ! Create variable node call code_val(coder,cblock) - call code_val(coder,name) + call code_num(coder,name) ! Flag variables according to current par state vflags=flags - if(coder%par_state>=par_state_cond) then - vflags=ior(vflags,var_is_incomplete) - endif - if(coder%par_state==par_state_par) then - vflags=ior(vflags,var_is_par_var) - endif ! All named variables multi access (this may change) call code_num(coder,ior(vflags,var_is_multi_access)) call code_null(coder) coder%index=coder%index+1 call code_num(coder,coder%index) - call code_val(coder,pm_fast_tinyint(coder%context,& - coder%par_depth-coder%proc_par_depth)) - call code_val(coder,pm_fast_tinyint(coder%context,& - coder%par_depth-coder%proc_par_depth)) call code_num(coder,coder%lex_scope) if(present(extra_info)) then call code_val(coder,extra_info) @@ -6535,8 +6093,11 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) call make_code(coder,node,cnode_is_var,var_node_size) endif + ! write(*,*) 'make-var>',trim(pm_name_as_string(coder%context,int(name%offset))),coder%index + + ! Add variable to stack - call push_var(coder,int(name%offset),top_code(coder)) + call push_var(coder,name,top_code(coder)) ! Link variable to enclosing code block link=cnode_get(cblock,cblock_last_var) @@ -6567,8 +6128,15 @@ subroutine push_var(coder,name,var) type(code_state),intent(inout):: coder integer:: name type(pm_ptr),intent(in):: var - integer:: i,j + integer:: j + +!!$ if(coder%top==9) then +!!$ write(*,*) 'Push',var%data%vkind,cnode_get_kind(var) +!!$ call qdump_code_tree(coder,pm_null_obj,6,var,2) +!!$ if(cnode_get_kind(var)/=cnode_is_var) call pm_panic('poo') +!!$ endif + if(name==0) return if(coder%top>=max_code_stack) then call pm_panic('Program too complex') @@ -6577,7 +6145,6 @@ subroutine push_var(coder,name,var) j=coder%top coder%stack(j)=name coder%var(j)=var - coder%imps(j)=0 end subroutine push_var !===================================== @@ -6586,31 +6153,9 @@ end subroutine push_var subroutine pop_vars_to(coder,newbase) type(code_state),intent(inout):: coder integer,intent(in):: newbase - integer:: i,old_top + integer:: old_top old_top=coder%top coder%top=newbase - do i=newbase+1,old_top -!!$ if(cnode_flags_clear(coder%var(i),var_flags,var_is_accessed+var_is_changed)) then -!!$ call cnode_error(coder,coder%var(i),'Variable is defined but never used: ',& -!!$ cnode_get(coder%var(i),var_name)) -!!$ endif - if(coder%imps(i)/=0) then - if(coder%imps(i)<=coder%par_depth) then - ! Keep imports to current parallel scope - coder%top=coder%top+1 - coder%imps(coder%top)=coder%imps(i) - coder%stack(coder%top)=coder%stack(i) - coder%var(coder%top)=coder%var(i) - elseif(par_depth(coder,coder%var(i))=pm_int) then - tno=pm_new_literal_type(coder%context,val) + tno=pm_new_literal_value_type(coder%context,val) else tno=pm_fast_typeof(val) endif - if(coder%par_state/=par_state_outer) then - tno=pm_type_add_mode(coder%context,tno,sym_invar) - endif + tno=pm_type_add_mode(coder%context,tno,sym_invar) call code_val(coder,val) call code_num(coder,tno) call make_code(coder,node,cnode_is_const,2) @@ -6742,15 +6285,15 @@ subroutine make_sp_call(coder,cblock,node,sym,nargs,nret,flags) type(pm_ptr),intent(in):: cblock,node integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: flags - integer:: depth,base,aflags + integer:: aflags aflags=0 if(present(flags)) aflags=flags call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.) call code_null(coder) call make_full_call(coder,cblock,node,& pm_fast_tinyint(coder%context,-sym),pm_null_obj,nargs,abs(nret),0,& - pm_null_obj,ior(aflags,coder%run_flags),& - pm_null_obj,coder%par_depth) + pm_null_obj,aflags,& + pm_null_obj) contains include 'ftiny.inc' end subroutine make_sp_call @@ -6771,16 +6314,16 @@ end subroutine make_sp_call_rtn ! Make a procedure call cnode for some builtin operations ! (does not create imports/exports) !================================================================== - subroutine make_basic_sp_call(coder,cblock,node,sym,nargs,nret,depth) + subroutine make_basic_sp_call(coder,cblock,node,sym,nargs,nret) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,nargs,nret,depth + integer,intent(in):: sym,nargs,nret call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.,notouch=.true.) call code_null(coder) call make_full_call(coder,cblock,node,& pm_fast_tinyint(coder%context,-sym),pm_null_obj,& - nargs,abs(nret),0,pm_null_obj,coder%run_flags,& - pm_null_obj,depth) + nargs,abs(nret),0,pm_null_obj,0,& + pm_null_obj) contains include 'ftiny.inc' end subroutine make_basic_sp_call @@ -6796,14 +6339,13 @@ subroutine make_sys_call(coder,cblock,node,sym,& integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: aflags logical,intent(in),optional:: assign - type(pm_ptr):: procs,svect,avec - integer:: flags,depth,base + type(pm_ptr):: procs,avec + integer:: flags if(present(aflags)) then flags=aflags else flags=0 endif - flags=ior(flags,coder%run_flags) if(present(assign)) then avec=coder%std_amp else @@ -6816,7 +6358,7 @@ subroutine make_sys_call(coder,cblock,node,sym,& pm_fast_name(coder%context,sym)) call make_full_call(coder,cblock,node,& procs,avec,nargs+1,abs(nret),0,& - pm_null_obj,flags,pm_null_obj,coder%par_depth) + pm_null_obj,flags,pm_null_obj) contains include 'fname.inc' end subroutine make_sys_call @@ -6849,13 +6391,13 @@ subroutine make_comm_sys_call(coder,cblock,node,sym,& integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: aflags logical,intent(in),optional:: assign - type(pm_ptr):: procs,svect,avec - integer:: depth,flags,base,narg + type(pm_ptr):: procs,avec + integer:: flags,narg narg=nargs+num_comm_args if(present(aflags)) then - flags=ior(aflags,proccall_is_comm) + flags=ior(aflags,proccall_is_comm+proccall_is_general) else - flags=proccall_is_comm + flags=proccall_is_comm+proccall_is_general endif if(present(assign)) then avec=coder%comm_amp @@ -6868,7 +6410,7 @@ subroutine make_comm_sys_call(coder,cblock,node,sym,& call code_null(coder) call make_full_call(coder,cblock,node,& procs,avec,narg,abs(nret),0,pm_null_obj,flags,& - pm_null_obj,coder%par_depth) + pm_null_obj) contains include 'fname.inc' end subroutine make_comm_sys_call @@ -6908,39 +6450,72 @@ end subroutine make_assign_call ! with no processing of imports/exports ! Returns must precede arguments on the stack !================================================= - subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,depth,flags) + subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,flags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret,depth,flags - type(pm_ptr):: procs,svect + integer,intent(in):: sym,narg,nret,flags + type(pm_ptr):: procs procs=find_sig(coder,node,& pm_fast_name(coder%context,sym)) call make_arglist(coder,cblock,node,narg,nret,.true.,.false.,.true.) call code_null(coder) call make_full_call(coder,cblock,node,& procs,pm_null_obj,narg+1,abs(nret),0,pm_null_obj,& - ior(flags,coder%run_flags),pm_null_obj,depth) + flags,pm_null_obj) contains include 'fname.inc' end subroutine make_basic_sys_call + subroutine make_full_sys_call(coder,cblock,node,sym,& + nargs,nret,amps,keys,keynames,flags) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,amps,keys,keynames + integer,intent(in):: sym,nargs,nret,flags + type(pm_ptr):: procs + integer:: narg,nkeys + narg=nargs+num_comm_args + nkeys=0 + if(.not.pm_fast_isnull(keys)) nkeys=cnode_numargs(keys) + procs=find_sig(coder,node,& + pm_fast_name(coder%context,sym)) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.true.) + call code_val(coder,keys) + call make_full_call(coder,cblock,node,& + procs,amps,narg,abs(nret),nkeys,keynames,flags,& + pm_null_obj) + contains + include 'fname.inc' + include 'fisnull.inc' + end subroutine make_full_sys_call + + !========================================== ! Make a procedure call ! Argument list and key argument list (or null) ! must be on top of vstack. !========================================== subroutine make_full_call(coder,cblock,node,procs,& - amps,nargs,nret,nkeys,keynames,iflag,var,depth) + amps,nargs,nret,nkeys,keynames,flags,var) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,procs,amps,var,keynames - integer,intent(in):: nargs,nret,nkeys,iflag,depth - type(pm_ptr):: p,q,n,args,keys - integer:: i + integer,intent(in):: nargs,nret,nkeys,flags + type(pm_ptr):: p,n + integer:: iflag + if(pm_debug_checks) then if(cnode_get_kind(cblock)/=cnode_is_cblock) then call pm_panic('full call cblock') endif endif + + iflag=flags + if(coder%par_state>=par_state_masked) then + iflag=ior(flags,call_is_cond) + endif + if(coder%par_state==par_state_cond.or.& + coder%par_state==par_state_par) then + iflag=ior(flags,call_is_unlabelled) + endif call code_val(coder,cblock) call code_val(coder,procs) call code_num(coder,iflag) @@ -6950,7 +6525,6 @@ subroutine make_full_call(coder,cblock,node,procs,& call code_val(coder,keynames) coder%index=coder%index+1 call code_num(coder,coder%index) - call code_num(coder,depth-coder%proc_par_depth) call code_val(coder,var) call code_val(coder,amps) call make_code(coder,node,cnode_is_call,call_node_size) @@ -6971,9 +6545,8 @@ subroutine make_full_call(coder,cblock,node,procs,& call pm_ptr_assign(coder%context,cblock,& int(cblock_last_call,pm_ln),n) endif + n=pop_code(coder) - - !write(*,*) '#nargs=',cnode_numargs(cnode_get(n,call_args)) coder%proc_ncalls=coder%proc_ncalls+1 contains @@ -6990,12 +6563,13 @@ end subroutine make_full_call ! - if nret<0 then nret temp variables created and left ! on vstack before the argument list cnode !======================================================== - subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,iscomm,notouch) + recursive subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,& + iscomm,notouch,comm_args_present) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: nargs,nret logical,intent(in):: isstd,iscomm - logical,intent(in),optional:: notouch + logical,intent(in),optional:: notouch,comm_args_present integer:: i,ret0,arg0,extra0,nextra,base type(pm_ptr):: arglist @@ -7015,8 +6589,14 @@ subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,iscomm,notouch) ret0=arg0-nret base=ret0 endif - + if(iscomm) then + do i=1,abs(nret) + call cnode_set_flags(coder%vstack(ret0+i),var_flags,var_is_maybe_not_private) + enddo + endif + + if(iscomm.and..not.present(comm_args_present)) then extra0=coder%state_base nextra=num_comm_args-1 elseif(isstd) then @@ -7027,7 +6607,8 @@ subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,iscomm,notouch) nextra=0 endif - arglist=make_arglist_cnode(coder,node,abs(nret),ret0,nextra,extra0,iscomm,nargs,arg0) + arglist=make_arglist_cnode(coder,node,abs(nret),ret0,nextra,extra0,& + iscomm.and..not.present(comm_args_present),nargs,arg0) if(nret<0) then if(ret0>base) then do i=1,-nret @@ -7046,15 +6627,22 @@ subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,iscomm,notouch) include 'fvkind.inc' subroutine update_arg(p) - type(pm_ptr)::p -!!! check for chan and deref if required + type(pm_ptr),intent(inout)::p !!! Check for block import if(pm_fast_vkind(p)==pm_pointer) then if(cnode_get_kind(p)==cnode_is_var) then call update_change_lists(coder,p,.false.) +!!$ if(.not.iscomm) then +!!$ if(cnode_flags_set(p,var_flags,var_is_maybe_not_private)) then +!!$ call code_val(coder,p) +!!$ call make_comm_sys_call_rtn(coder,cblock,node,sym_dechan,1,1) +!!$ p=pop_code(coder) +!!$ endif +!!$ endif endif endif end subroutine update_arg + end subroutine make_arglist !================================= @@ -7179,7 +6767,7 @@ subroutine make_code_stem(coder,node,ckind,nargs) type(pm_ptr),intent(in):: node integer,intent(in):: ckind,nargs type(pm_ptr):: modl - integer:: i,ii + integer:: ii coder%temp=pm_fast_newnc(coder%context,pm_pointer,& nargs+cnode_args) if(pm_debug_checks.and..false.) then @@ -7314,7 +6902,6 @@ end subroutine swap_code !=========================================================== subroutine swap_and_dup_code(coder) type(code_state),intent(inout):: coder - type(pm_ptr):: temp coder%vstack(coder%vtop+1)=coder%vstack(coder%vtop-1) coder%vstack(coder%vtop-1)=coder%vstack(coder%vtop) coder%vtop=coder%vtop+1 @@ -7343,6 +6930,19 @@ subroutine swap_code_2_1(coder) coder%vstack(coder%vtop-1)=temp end subroutine swap_code_2_1 + !====================================================== + ! Swap top item on the stack with 2 items below + ! ... a b c -> ... c a b + !====================================================== + subroutine swap_code_1_2(coder) + type(code_state),intent(inout):: coder + type(pm_ptr):: temp + temp=coder%vstack(coder%vtop) + coder%vstack(coder%vtop)=coder%vstack(coder%vtop-1) + coder%vstack(coder%vtop-1)=coder%vstack(coder%vtop-2) + coder%vstack(coder%vtop-2)=temp + end subroutine swap_code_1_2 + !================================= ! Pop value from vstack !================================= @@ -7490,10 +7090,9 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) else call pm_name_string(coder%context,int(p%offset),str) endif - write(iunit,'(A,A," Idx=",I4," Dep=",I4," Chng=",L1," Flags=",I4,"offset=",I6,I6,L)') & + write(iunit,'(A,A," Idx=",I4," Chng=",L1," Flags=",I4,"offset=",I6,I6,L)') & spaces(1:depth*2),trim(str),& cnode_get_num(node,var_index),& - cnode_get_num(node,var_par_depth),& cnode_flags_set(node,var_flags,var_is_changed),& cnode_get_num(node,var_flags),node%offset,node%data%hash,marked(node) if(.not.pm_fast_isnull(rvec)) then @@ -7520,24 +7119,29 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) 'Call "',trim(sym_names(-p%offset)),'":',& cnode_get_num(node,call_index) else - p=pm_dict_key(coder%context,coder%sig_cache,& - int(p%offset,pm_ln)) - call pm_name_string(coder%context,& - p%data%i(p%offset+pm_fast_esize(p)),str) - write(iunit,'(A,A,A,A," Idx=",I4," Depth=",I4," Flags=",I4,"<",I4,">")') & + write(iunit,*) 'ISS>',p%offset + if(p%offset==0) then + str='varcall' + else + p=pm_dict_key(coder%context,coder%sig_cache,& + int(p%offset,pm_ln)) + call pm_name_string(coder%context,& + p%data%i(p%offset+pm_fast_esize(p)),str) + endif + write(iunit,'(A,A,A,A," Idx=",I4," Flags=",I4,"<",I4,">")') & spaces(1:depth*2),'Call (',trim(str),') (',& cnode_get_num(node,call_index),& - cnode_get_num(node,call_par_depth),cnode_get_num(node,call_flags),po + cnode_get_num(node,call_flags),po endif if(.not.pm_fast_isnull(rvec)) then i= rvec%data%i(rvec%offset+& cnode_get_num(node,call_index)) if(i<0) then - if(i==spsig_thru) then + if(i==sp_sig_link) then write(iunit,*) spaces(1:depth*2),' sp_sig_thru' - elseif(i==spsig_dup) then + elseif(i==sp_sig_dup) then write(iunit,*) spaces(1:depth*2),' sp_sig_dup' - elseif(i==spsig_noop) then + elseif(i==sp_sig_noop) then write(iunit,*) spaces(1:depth*2),' sp_sig_noop' elseif(p%offset>=0) then write(iunit,*) spaces(1:depth*2),' Unresolved Sig!!' @@ -7828,11 +7432,6 @@ function sig_as_str(coder,name,ampl,numargs,nret,flags,args) result(str) endif endif str(n:n)=')' - if(.not.present(args).and.& - iand(flags,proccall_is_comm)/=0& - .and.coder%par_state>=par_state_cond) then - str(n+2:)='Conditional context' - endif contains include 'fisnull.inc' @@ -7856,10 +7455,9 @@ subroutine code_error(coder,node,message,name,warn) type(code_state):: coder type(pm_ptr),intent(in):: node character(len=*):: message - type(pm_ptr),intent(in),optional:: name + integer,intent(in),optional:: name logical,intent(in),optional:: warn character(len=256):: str - type(pm_ptr):: modname if(pm_main_process) then write(*,*) if(.not.pm_fast_isnull(node)) then @@ -7868,7 +7466,7 @@ subroutine code_error(coder,node,message,name,warn) endif if(.not.present(warn)) then if(present(name)) then - call pm_name_string(coder%context,int(name%offset),str) + call pm_name_string(coder%context,name,str) str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) else str=trim(pm_opts%error)//' '//message @@ -7898,7 +7496,6 @@ subroutine cnode_error(coder,node,message,name,warn) type(pm_ptr),intent(in),optional:: name logical,intent(in),optional:: warn character(len=256):: str - type(pm_ptr):: modname if(pm_main_process) then call pm_error_header(coder%context,& cnode_get_name(node,cnode_modl_name),& diff --git a/src/infer.f90 b/src/infer.f90 index 9c18237..4f34fdb 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2024 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -55,16 +55,7 @@ module pm_infer ! Maximum times a procedure template can call itself with ! *different* arguments types each time integer,parameter:: max_recur=32 - - ! Special signatures - integer,parameter:: sp_sig_in_process=-1_pm_p - integer,parameter:: sp_sig_recursive=-2_pm_p - integer,parameter:: sp_sig_break=-3_pm_p - integer,parameter:: sp_sig_thru=-4_pm_p - integer,parameter:: sp_sig_dup=-5_pm_p - integer,parameter:: sp_sig_noop=-6_pm_p - integer,parameter:: sp_sig_setval=-7_pm_p - + ! Special types integer,parameter:: undefined=-1 integer,parameter:: error_type=-2 @@ -86,7 +77,6 @@ module pm_infer ! calls at compile time !============================================================= - !============================== ! Type-infer main program !============================== @@ -95,7 +85,7 @@ subroutine inf_prog(coder) type(pm_ptr):: cnode integer:: i - if(debug_inference) write(*,*) 'PRC PROG>' + if(debug_inference) write(*,*) 'INF PROG>' coder%flag_recursion=.false. coder%trace_depth=0 @@ -105,8 +95,6 @@ subroutine inf_prog(coder) do coder%top=1 coder%wtop=1 - coder%par_kind2=par_mode_outer - coder%par_kind=par_mode_outer coder%types_finished=.true. coder%redo_calls=.false. coder%incomplete=.false. @@ -194,7 +182,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& iscomm=cnode_flags_set(procnode,pr_flags,proccall_is_comm) ! Dictionary entries in coder%proc_cache: - ! Key is proc and argument types and implicit par_kind + ! Key is proc and argument types ! Value is tiny int with procedure return type (if >0) ! or (-1) sp_in_process in process of resolution ! or (-2) sp_recursive called recursively @@ -204,7 +192,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& key(1)=cnode_get_num(procnode,pr_id) key(2)=atype keysize=2 - + ! Process keyword arguments - they form part of the hash key last_key_index=0 if(proc_nkeys>0) then @@ -222,6 +210,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& 'Procedure definition corresponding to the above error') endif + ! Process when expression nomatch=.false. if(.not.pm_fast_isnull(cnode_get(procnode,pr_when))) then if(proc_nkeys==0) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) @@ -246,17 +235,18 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& nomatch=.false. return endif - + + ! Lookup combination of proc, arg types and all key types + ! defined for the procedure (including defaults) + k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) + if(debug_inference) then - write(*,*) 'PRC PROC>',key(1),key(2),k,& + write(*,*) 'INF PROC>',key(1),key(2),k,& trim(pm_name_as_string(coder%context,& cnode_get_name(procnode,pr_name))),& trim(pm_type_as_string(coder%context,atype)) endif - ! Lookup combination of proc, arg types and all key types - ! defined for the procedure (including defaults) - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) ! This combination already cached if(k>0) then @@ -465,13 +455,12 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call code_int_vec(coder,coder%stack,coder%base,coder%top) call code_num(coder,& ior(iand(cnode_get_num(procnode,pr_flags),& - proccall_is_comm+proc_run_shared+proc_run_local+proccall_is_inline+& - proccall_is_no_inline+proc_run_complete+proc_run_always),& + proccall_is_comm+proccall_is_inline+proccall_is_no_inline),& coder%taints)) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) cnode=top_code(coder) if(debug_inference) then - write(*,*) coder%par_kind,'CACHE AS>',key(1:keysize),'>',cnode%offset + write(*,*) 'CACHE AS>',key(1:keysize),'>',cnode%offset endif k=pm_idict_add(coder%context,coder%proc_cache,& key,keysize,cnode) @@ -543,7 +532,7 @@ subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& logical:: nomatch,error type(pm_ptr):: callkeys,proc_keys,arglist,tv integer:: nargs,totargs,tno - + proc_keys=cnode_get(procnode,pr_keys) ! Need to infer standard arguments in case they are @@ -573,16 +562,15 @@ subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& call inf_error(coder,procnode,& 'Procedure definition corresponding to the above error') enddo outer - + ! For each keyword parameter, infer the default type and then ! determine keyword argument matching with any required conversions ! - match_arg will leave conversion records on the vstack do i=1,n call inf_cblock(coder,cnode_arg(arglist,i*2-1+n+n)) - dtype = get_arg_type(coder,callnode,cnode_arg(arglist,i*2+n+n)) - if(pm_type_kind(coder%context,dtype)==pm_type_is_literal) then - dtype=pm_type_arg(coder%context,dtype,1) - endif + + dtype = pm_type_strip_literal(coder%context,get_arg_type(coder,callnode,cnode_arg(arglist,i*2+n+n))) + if(keytypes(i)>=0) then ptype=proc_keys%data%i(proc_keys%offset+i-1+n) pdtype=merge(ptype,dtype,ptype>=0) @@ -612,14 +600,13 @@ subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& keytypes(i)=dtype endif call set_var_type(coder,cnode_arg(arglist,i),keytypes(i)) - call set_var_type(coder,cnode_arg(arglist,i+n),keytypes(i)) + call set_var_type(coder,cnode_arg(arglist,i+n),keytypes(i)) enddo contains include 'fesize.inc' include 'fisnull.inc' end subroutine inf_key_args - ! ================================================== ! Type infer builtin procedure ! =================================================== @@ -631,8 +618,7 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) integer,dimension(1):: key integer:: k,t1,n type(pm_ptr):: tv,v - type(pm_type_einfo):: einfo - logical:: isstatic + logical:: isstatic,iscomm if(debug_inference) then write(*,*) 'BUILTIN>',trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) @@ -650,23 +636,38 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) endif endif - atype1=pm_type_strip_mode(coder%context,pm_type_arg(coder%context,atype,2),mode) + if(cnode_flags_set(procnode,pr_flags,proccall_is_comm)) then + atype1=pm_type_arg(coder%context,atype,1+num_comm_args) + else + atype1=pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,2),mode) + endif ! special handling of return types for some operations select case(cnode_get_num(procnode,bi_opcode)) - case(min_op:-1) + case(first_fold:last_fold) rtype=fold(coder,procnode,atype,rtype) call code_num(coder,sp_sig_setval) goto 10 + case(op_clone_var) + k=cnode_get_num(procnode,bi_opcode2) + rtype=atype1 + if(k/=0) rtype=pm_type_replace_mode(coder%context,rtype,k) + call code_num(coder,sp_sig_dup) + goto 10 case(op_extractelm) rtype=pm_type_arg(coder%context,atype1,1) case(op_get_dom) rtype=pm_type_arg(coder%context,atype1,2) case(op_as,op_get_poly_or) rtype=pm_type_arg(coder%context,atype,3) - case(op_import_val,op_import_varg,op_broadcast_val,& - op_clone,op_get_rf) + case(op_import_varg,op_broadcast_val,& + op_get_rf) + rtype=atype1 + case(op_clone) + k=cnode_get_num(procnode,bi_opcode2) rtype=atype1 + if(k/=0) rtype=pm_type_replace_mode(coder%context,rtype,k) case(op_elem) n=cnode_get_num(procnode,bi_opcode2) if(n/=0) then @@ -684,13 +685,13 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) endif else tv=pm_type_vect(coder%context,atype) - t1=pm_tv_arg(tv,8) + t1=pm_type_strip_mode(coder%context,pm_tv_arg(tv,8),mode) v=pm_type_val(coder%context,t1) n=v%data%ln(v%offset) t1=pm_type_strip_mode(coder%context,pm_tv_arg(tv,7),mode) tv=pm_type_vect(coder%context,t1) k=pm_tv_kind(tv) - if(k/=pm_type_is_struct.and.k/=pm_type_is_rec.and.k/=pm_type_is_tuple) then + if(k/=pm_type_is_rec.and.k/=pm_type_is_tuple) then call inf_error_with_trace(coder,callnode,& 'Cannot apply ".element_at_index" to: '//& trim(pm_type_as_string(coder%context,t1))) @@ -727,6 +728,20 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) if(pm_tv_kind(tv)==pm_type_is_vect) then rtype=pm_tv_arg(tv,1) endif + case(op_import_val) + t1=pm_type_strip_mode(coder%context,atype1,mode) + if(mode==sym_shared) then + rtype=pm_error_type_from_string(coder%context,'Cannot import '//& + '"shrd" value into a new parallel context') + else + rtype=pm_type_add_mode(coder%context,t1,& + merge(sym_shared,sym_invar,& + iand(pm_type_flags(coder%context,t1),pm_type_has_distributed)/=0)) + endif + case(op_list_concat) + call infer_list_concat + case(op_list_splice) + call infer_list_splice end select ! Create cache entry @@ -743,187 +758,81 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) return -!!$ ! Check cached type value -!!$! p=cnode_get(procnode,bi_rcode) -!!$ if(pm_fast_istiny(p)) then -!!$ ! Result is type of one of the arguments -!!$ tv=pm_type_vect(coder%context,atype) -!!$ tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) -!!$ rtype=(pm_tv_arg(tv,int(p%offset))) -!!$ elseif(pm_fast_isnull(p)) then -!!$ ! A an actual return type has been specified -!!$! rtype=cnode_get_num(procnode,bi_rtype) -!!$ if(rtype<0) then -!!$ ! Cached concrete return type -!!$ rtype=-rtype -!!$ else -!!$ ! Convert type to concrete only representation and cache it -!!$ if(rtype/=0) then -!!$ rtype=pm_type_as_concrete(coder%context,rtype,coder%wstack,& -!!$ isstatic) -!!$ ! if(isstatic) call cnode_set_num(procnode,bi_rtype,int(-rtype)) -!!$ endif -!!$ endif -!!$ if(cnode_get_num(procnode,bi_opcode)<0) then -!!$ rtype=fold(coder,procnode,atype,rtype) -!!$ call code_num(coder,sp_sig_setval) -!!$ goto 10 -!!$ endif -!!$ else -!!$ ! Process code for return expression to get base return type -!!$ call create_stack_frame(coder,atype,cnode_num_arg(procnode,2),0) -!!$ ! call inf_cblock(coder,cnode_get(procnode,bi_rcode)) -!!$ rtype=coder%stack(coder%base) -!!$ call pop_stack_frame(coder) -!!$ -!!$ ! Special processing of return type -!!$ ! Specified by special character in return spec -!!$! sym=cnode_get_num(procnode,bi_rsym) -!!$ if(rtype/=error_type) then -!!$ -!!$ select case(sym) -!!$ case(sym_hash,sym_pct) -!!$ tv=pm_type_vect(coder%context,rtype) -!!$ tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) -!!$ if(sym==sym_hash) then -!!$ rtype=(pm_tv_arg(tv,2)) -!!$ else -!!$ rtype=(pm_tv_arg(tv,1)) -!!$ endif -!!$ case(sym_dim1:sym_dim7) -!!$ tv=pm_type_vect(coder%context,rtype) -!!$ tv=pm_type_vect(coder%context,pm_type_strip_mode(coder%context,& -!!$ pm_tv_arg(tv,1),mode)) -!!$ if(pm_tv_kind(tv)==pm_type_is_vect) then -!!$ tv=pm_type_vect(coder%context,pm_tv_arg(tv,1)) -!!$ endif -!!$ rtype=pm_tv_arg(tv,int(sym-sym_dim1+1)) -!!$ case(sym_d1:sym_d7) -!!$ tv=pm_type_vect(coder%context,rtype) -!!$ tv=pm_type_vect(coder%context,pm_type_strip_mode(coder%context,& -!!$ pm_tv_arg(tv,1),mode)) -!!$ if(pm_tv_kind(tv)==pm_type_is_vect) then -!!$ rtype=pm_tv_arg(tv,1) -!!$ tv=pm_type_vect(coder%context,rtype) -!!$ rtype=pm_type_strip_mode(coder%context,pm_tv_arg(tv,int(sym-sym_d1+1)),mode) -!!$ if(modepm_tv_numargs(tv)) then -!!$ call inf_error_with_trace(coder,procnode,& -!!$ 'Internal error: PM__element_at: out of bounds') -!!$ rtype=error_type -!!$ else -!!$ rtype=pm_tv_arg(tv,t2) -!!$ endif -!!$ end select -!!$ endif -!!$ endif -!!$ ! Create cache entry -!!$ key(1)=-cnode_get_num(procnode,bi_id)-1 -!!$ k=pm_idict_add(coder%context,& -!!$ coder%proc_cache,key,1,procnode) -!!$ call code_num(coder,k) -!!$ -!!$10 continue -!!$ -!!$ ! Pass out taint information -!!$ coder%proc_taints=iand(proc_taints,cnode_get_num(procnode,pr_flags)) -!!$ coder%taints=ior(coder%taints,coder%proc_taints) contains include 'fisnull.inc' include 'fistiny.inc' include 'fnew.inc' - include 'fvkind.inc' + include 'fvkind.inc' + + subroutine infer_list_concat + call push_word(coder,pm_type_new_tuple) + call push_word(coder,0) + n=coder%wtop + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + tv=pm_type_vect(coder%context,atype1) + do k=1,pm_tv_numargs(tv) + call push_word(coder,pm_tv_arg(tv,k)) + enddo + t1=pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,3),mode) + tv=pm_type_vect(coder%context,t1) + do k=1,pm_tv_numargs(tv) + call push_word(coder,pm_tv_arg(tv,k)) + enddo + call make_type_if_possible(coder,coder%wtop-n) + call make_type_if_possible(coder,3) + rtype=pop_word(coder) + end subroutine infer_list_concat + + subroutine infer_list_splice + type(pm_ptr):: tv,tv2,arg + integer:: k,base,i,siz,t1 + arg=pm_type_val(coder%context,& + pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,4),mode)) + i=arg%data%ln(arg%offset) + arg=pm_type_val(coder%context,& + pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,5),mode)) + siz=arg%data%ln(arg%offset) + tv=pm_type_vect(coder%context,atype1) + if(i<0.or.i>=pm_tv_numargs(tv)) then + call inf_error(coder,callnode,& + 'Internal error: Bad index in splice_list: '//& + trim(pm_int_as_string(i))//' with list size='//& + trim(pm_int_as_string(pm_tv_numargs(tv)))) + endif + if(siz<0.or.i+siz>=pm_tv_numargs(tv)) then + call inf_error(coder,callnode,& + 'Internal error: Bad size in splice_list: '//& + trim(pm_int_as_string(siz))//& + ' with index='//trim(pm_int_as_string(i))//' and list size='//& + trim(pm_int_as_string(pm_tv_numargs(tv)))) + endif + call push_word(coder,pm_type_new_tuple) + call push_word(coder,0) + base=coder%wtop + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + + do k=1,i + call push_word(coder,pm_tv_arg(tv,k)) + enddo + t1=pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,3),mode) + tv2=pm_type_vect(coder%context,t1) + do k=1,pm_tv_numargs(tv2) + call push_word(coder,pm_tv_arg(tv2,k)) + enddo + do k=i+2+siz,pm_tv_numargs(tv) + call push_word(coder,pm_tv_arg(tv,k)) + enddo + call make_type_if_possible(coder,coder%wtop-base) + call make_type_if_possible(coder,3) + rtype=pop_word(coder) + end subroutine infer_list_splice + end function inf_builtin !========================================== @@ -956,12 +865,10 @@ subroutine inf_call(coder,cblock,callnode) type(pm_ptr):: args,t,t2,tv,list,list2,namep integer:: i,j,n,nret,nargs,slot,slot2,tbase,wbase integer:: vbase_check,tbase_check,counter,nerrors - integer:: save_par_kind integer,dimension(2):: key logical:: ok,isstatic,mayfail,undef_arg,cond integer(pm_ln):: k character(len=100):: str - type(pm_type_einfo):: einfo if(pm_debug_checks) then vbase_check=coder%vtop @@ -1003,7 +910,7 @@ subroutine inf_call(coder,cblock,callnode) enddo if(cblock_has_comm(cnode_arg(args,1))& .or.cblock_has_comm(cnode_arg(args,3))) then - call set_call_sig(merge(1,0,coder%par_kind2<=par_mode_conc)) + !!! call set_call_sig(merge(1,0,coder%par_kind2<=par_mode_conc)) else call set_call_sig(0) endif @@ -1024,89 +931,24 @@ subroutine inf_call(coder,cblock,callnode) enddo call check_logical(2) if(cblock_has_comm(list)) then - call set_call_sig(merge(1,0,coder%par_kind<=par_mode_conc)) + !!! call set_call_sig(merge(1,0,coder%par_kind<=par_mode_conc)) else call set_call_sig(0) endif case(sym_if,sym_if_invar) call inf_if(count_updates(cnode_arg(args,4),2)) - case(sym_do,sym_for,sym_also) + case(sym_pm_for,sym_pm_over) + call inf_cblock(coder,cnode_arg(args,2)) + case(sym_do,sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) call inf_cblock(coder,cnode_arg(args,1)) case(sym_sync) call inf_cblock(coder,cnode_arg(args,2)) - case(sym_over) - call inf_cblock(coder,cnode_arg(args,1)) + case(sym_pct) call inf_cblock(coder,cnode_arg(args,2)) - case(sym_import_val,sym_import_param) - tno=pm_type_strip_mode(coder%context,arg_type_with_mode(2),mode) - if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then - call inf_error_with_trace(coder,callnode,& - 'Cannot import uninitialised value into a nested parallel context:',& - cnode_get(cnode_arg(args,2),var_name)) - coder%stack(get_slot(1))=error_type - else - mode=merge(sym_shared,sym_invar,& - iand(pm_type_flags(coder%context,tno),& - pm_type_has_distributed)/=0) - coder%stack(get_slot(1))=pm_type_add_mode(coder%context,tno,& - mode) - if(tno>0.and.coder%par_kind==par_mode_conc.and.mode==sym_shared) then - if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then - call inf_error_with_trace(coder,callnode,& - 'Cannot import distributed value into mirrored "forall"') - coder%stack(get_slot(1))=error_type - endif - endif - call flag_import_export(tno) - endif - case(sym_import_varg) - tno=arg_type(2) - if(tno>0) then - t=pm_type_vect(coder%context,arg_type(2)) - n=pm_tv_numargs(t) - call push_word(coder,pm_type_new_tuple) - call push_word(coder,0) - do i=1,n - tno=pm_type_strip_mode(coder%context,pm_tv_arg(t,i),mode) - if(iand(pm_type_flags(coder%context,tno),pm_type_has_distributed)/=0) then - call inf_error_with_trace(coder,callnode,& - 'Cannot use a shared value as an argument'//& - ' to a non-communicating operation') - endif - call push_word(coder,& - pm_type_add_mode(coder%context,tno,sym_invar)) - enddo - call make_type(coder,n+2) - tno=pop_word(coder) - coder%stack(get_slot(1))=tno - call flag_import_export(tno) - endif case(sym_null) do i=1,nret coder%stack(get_slot(i))=pm_null enddo - case(sym_export) - tno=arg_type_with_mode(1) - mode=pm_type_get_mode(coder%context,tno) - if(mode/=sym_private) then - call inf_error(coder,callnode,& - 'Cannot modify "'//trim(sym_names(mode))//'" variable as a "shared" value '//& - 'in a nested parallel statement: '//& - trim(pm_name_as_string(coder%context,& - cnode_get_name(cnode_arg(args,1),var_name)))) - call inf_error_with_trace(coder,cnode_arg(args,1),& - 'Definition of variable in above error') - endif - call flag_import_export(0) - case(sym_export_as_new,sym_export_param) - coder%stack(get_slot(1))=arg_type_with_mode(2) - call flag_import_export(arg_type(1)) - case(sym_amp_error) - if(nargs>0) then - coder%stack(get_slot(1))=arg_type_with_mode(2) - endif - call inf_error_with_trace(coder,callnode,& - 'Cannot change variable in different parallel context') case(sym_pm_send:sym_pm_serve) call check_long(5) coder%taints=ior(coder%taints,proc_is_impure) @@ -1177,7 +1019,11 @@ subroutine inf_call(coder,cblock,callnode) if(debug_inference) write(*,*) 'DREF=',& trim(pm_type_as_string(coder%context,top_word(coder))) coder%stack(get_slot(1))=pop_word(coder) - case(sym_struct,sym_rec) + case(sym_pm_each_index) + call inf_each_index + case(sym_pm_set_dotdotdot) + coder%stack(get_slot(1))=arg_type(2) + case(sym_rec) t=cnode_arg(args,2) t=cnode_arg(t,1) if(cnode_num_arg(args,3)>=0) then @@ -1189,11 +1035,7 @@ subroutine inf_call(coder,cblock,callnode) endif name=t%data%i(t%offset+2) - if(sig==sym_struct) then - call push_word(coder,pm_type_new_struct+t%data%i(t%offset+4)) - else - call push_word(coder,pm_type_new_rec+t%data%i(t%offset+4)) - endif + call push_word(coder,pm_type_new_rec+t%data%i(t%offset+4)) call push_word(coder,t%data%i(t%offset)) do i=1,nargs-2 call push_word(coder,arg_type_with_mode(i+3)) @@ -1239,19 +1081,18 @@ subroutine inf_call(coder,cblock,callnode) tno2=pop_word(coder) if(tno2>0) then if(.not.pm_type_includes(coder%context,tno,tno2,& - pm_type_incl_val,einfo)) then + pm_type_incl_val)) then call inf_error(coder,callnode,& '"'//trim(sym_names(sig))//& '" initial expression has wrong type for: ',& pm_fast_name(coder%context,name)) - call pm_type_error(coder%context,einfo) call inf_trace(coder) tno2=error_type endif endif tno2=pm_type_add_mode(coder%context,tno2,mode) call combine_types(cnode_arg(args,1),tno2) - case(sym_open_smiley) + case(sym_pm_list) call push_word(coder,pm_type_new_tuple+pm_type_is_list) call push_word(coder,0) do i=1,nargs @@ -1285,7 +1126,7 @@ subroutine inf_call(coder,cblock,callnode) tno=pm_type_strip_mode(coder%context,& tno,mode) if(tno>0) then - call set_call_sig(resolve_elem(tno,name,& + call set_call_sig(resolve_elem(cnode_arg(args,2),tno,name,& sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) call combine_types(cnode_arg(args,1),& pm_type_add_mode(coder%context,tno2,mode)) @@ -1396,16 +1237,16 @@ subroutine inf_call(coder,cblock,callnode) call check_logical(3) coder%stack(coder%base-2)=ior(coder%stack(coder%base-2),proc_is_impure) endif - case(sym_dash) + case(sym_fix,sym_literal) tno=arg_type(2) t=pm_type_vect(coder%context,tno) if(iand(pm_tv_flags(t),pm_type_has_storage)/=0) then call inf_error_with_trace(coder,callnode,& - 'Value after '' cannot be determined at compile time: '//& + 'Value in "'//trim(sym_names(sig))//'" cannot be determined at compile time: '//& trim(pm_type_as_string(coder%context,tno))) endif - if(pm_tv_kind(t)==pm_type_is_literal) then - tno=pm_new_fix_type(coder%context,pm_type_val(coder%context,tno),& + if(pm_tv_kind(t)==pm_type_is_literal_value) then + tno=pm_new_fix_value_type(coder%context,pm_type_val(coder%context,tno),& pm_tv_name(t)) endif coder%stack(get_slot(1))=tno @@ -1447,8 +1288,8 @@ subroutine inf_call(coder,cblock,callnode) call make_type_if_possible(coder,nargs+2) coder%stack(coder%base)=pop_word(coder) case(sym_start_loop) - coder%stack(get_slot(2))=pm_logical - case(sym_underscore,sym_colon,sym_end_loop,sym_init_var) + coder%stack(get_slot(2))=pm_logical + case(sym_underscore,sym_colon,sym_end_loop) continue case(first_pragma:last_pragma) if(sig==sym_infer_type.or.sig==sym_infer_type_and_stack) then @@ -1613,13 +1454,14 @@ subroutine inf_any(nupdates) end do enddo call make_code(coder,pm_null_obj,cnode_is_any_sig,n) - list=pop_code(coder) if(.not.coder%incomplete) then + list=top_code(coder) key(1)=pm_dict_size(coder%context,coder%proc_cache) k=pm_idict_add(coder%context,coder%proc_cache,& key,1,list) call set_call_sig(int(k)) endif + call drop_code(coder) else coder%stack(coder%base+slot:coder%base+slot2)=undefined call set_arg_to_error_type(1) @@ -1628,6 +1470,55 @@ subroutine inf_any(nupdates) end subroutine inf_any + subroutine inf_each_index() + type(pm_ptr):: p,tv + integer:: start,finish,tno,tno2,i,n,k,key(1) +!!! need to handle modes + + p=cnode_arg(args,nret+3) + p=cnode_arg(p,1) + start=p%data%i(p%offset) + finish=p%data%i(p%offset+1) + tno=arg_type(nret+1) + if(tno>0) then + k=pm_type_kind(coder%context,tno) + if(k==pm_type_is_literal_value.or.k==pm_type_is_fix_value) then + p=pm_type_val(coder%context,tno) + n=p%data%ln(p%offset) + else + call inf_error(coder,callnode,'Internal error: PM__each_index: not a literal or fix int parameter') + endif + else + n=1 + endif + if(nret>1) then + call push_word(coder,pm_type_new_tuple) + call push_word(coder,0) + endif + do i=1,n + coder%stack(coder%base+start:coder%base+finish)=undefined + coder%temp=pm_fast_newnc(coder%context,pm_long,1) + coder%temp%data%ln(coder%temp%offset)=i + coder%stack(get_slot(nret))=pm_new_fix_value_type(coder%context,coder%temp) + coder%temp=pm_null_obj + call inf_cblock(coder,cnode_arg(args,nret+2)) + call code_int_vec(coder,coder%stack,coder%base+start,coder%base+finish) + if(nret>1) then + call push_word(coder,arg_type(nret+4)) + endif + enddo + if(nret>1) then + call make_type_if_possible(coder,n+2) + coder%stack(get_slot(1))=pop_word(coder) + endif + call make_code(coder,pm_null_obj,cnode_is_any_sig,n) + p=pop_code(coder) + key(1)=pm_dict_size(coder%context,coder%proc_cache) + k=pm_idict_add(coder%context,coder%proc_cache,& + key,1,p) + call set_call_sig(k) + end subroutine inf_each_index + !=================================================================== ! Push argument types with modes for all arguments !================================================================== @@ -1843,51 +1734,55 @@ end subroutine set_call_sig !================================================================== ! Resolve signature for item.name - ! This is either 2.. for regular structures/records - ! or pm_type_dref_offset + 2 .. for offset into a dref - ! (starting at 2 is for historical reasons and is horrible) !================================================================== - recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) + recursive function resolve_elem(var,tno,name,isref,isopt,elem_type) result(sig) + type(pm_ptr),intent(in):: var integer,intent(in):: tno,name logical,intent(in):: isref,isopt integer,intent(out):: elem_type - integer:: base,sig - integer:: key(2) + integer:: sig,tk type(pm_ptr):: svec - base=coder%wtop sig=pm_type_find_elem(coder%context,tno,name,isref,& - coder%wstack,coder%wtop,max_code_stack,elem_type,einfo) - if(sig<0) then - key(1)=-name - key(2)=tno - sig=-pm_ivect_lookup(coder%context,coder%proc_cache,key,2) - if(sig==0) then - svec=pm_fast_newnc(coder%context,pm_int,& - coder%wtop-base+1) - svec%data%i(svec%offset)=elem_type - svec%data%i(svec%offset+1:svec%offset+pm_fast_esize(svec))=& - coder%wstack(base+1:coder%wtop) - sig=-pm_idict_add(coder%context,coder%proc_cache,& - key,2,svec) - endif - elseif(sig==0) then + elem_type) + if(sig==0) then if(.not.isopt) then - if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then + tk=pm_type_kind(coder%context,tno) + if(tk==pm_type_is_error) then + call inf_type_error(coder,callnode,tno,var) + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + elseif(tk==pm_type_is_uninitialised) then call inf_error(coder,callnode,& - 'Cannot take element of an uninitialised value') + 'Cannot take an element of an uninitialised value: ',& + cnode_get(var,var_name)) + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + elseif(tk/=pm_type_is_rec.and.tk/=pm_type_is_tuple) then + call inf_error(coder,callnode,& + 'Cannot take an element of a value of type: "'//& + trim(pm_type_as_string(coder%context,tno))//'": ',& + cnode_get(var,var_name)) else - call inf_error_with_trace(coder,callnode,& - 'Error accessing element "'//& - trim(pm_name_as_string(coder%context,name))//& - '" of type "'//& - trim(pm_type_as_string(coder%context,tno))//'"') - call pm_type_error(coder%context,einfo) + sig=pm_type_find_elem(coder%context,tno,name,.false.,& + elem_type) + if(sig==0) then + call inf_error_with_trace(coder,callnode,& + 'Type "'//trim(pm_type_as_string(coder%context,tno))//'"'//& + ' does not have an element named "'//& + trim(pm_name_as_string(coder%context,name))//'" in: ',& + cnode_get(var,var_name)) + else + call inf_error_with_trace(coder,callnode,& + 'Cannot modify element "'//& + trim(pm_name_as_string(coder%context,name))//& + '" of type "'//& + trim(pm_type_as_string(coder%context,tno))//'" in: ',& + cnode_get(var,var_name)) + sig=0 + endif endif endif elem_type=error_type endif - coder%wtop=base end function resolve_elem !================================================================== @@ -1985,7 +1880,6 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) nkey=0 endif - ! Push arguments types to stack call push_word(coder,pm_type_is_tuple) call push_word(coder,amps) @@ -1998,6 +1892,10 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) undef_arg=undef_arg.or.tno<=0 enddo + if(is_comm.and.is_cond) then + coder%wstack(coder%wtop+num_comm_args)=pm_logical + endif + ! Error return for error argument in if(undef_arg) then do i=1,nret @@ -2040,7 +1938,6 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) if(amps/=0.and..not.ignore_rules) then amplocs=pm_name_val(coder%context,amps) do i=0,pm_fast_esize(amplocs) - call qdump_code_tree(coder,pm_null_obj,6,amplocs,2) write(*,*) 'AMPLOC-->',amplocs%data%i(amplocs%offset+i),i,pm_fast_esize(amplocs) tno2=pm_type_strip_mode(coder%context,& coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey),mode2) @@ -2138,6 +2035,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) coder%wtop=coder%wtop-nargs-nkey-2 slot=coder%base+cnode_get_num(callnode,call_index) coder%stack(slot)=ressig + if(debug_inference) then write(*,*) 'END PROC CALL>',& trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop,ressig,slot,coder%base @@ -2167,26 +2065,16 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) type(pm_ptr):: tv,v,proc,match_proc,rtvect integer:: rt,rt2,pars,mpars,apars,tno,match_pars logical:: ok,found,visible,found_has_no_rtypes,when_no_match - integer:: save_par_kind,save_par_kind2 - type(pm_type_einfo):: einfo integer,dimension(1):: key integer:: memo - - ! Save some state information - save_par_kind=coder%par_kind - save_par_kind2=coder%par_kind2 - + if(present(err)) err=.false. start=coder%vtop if(present(sig_start)) start=sig_start - - ! For shared calls, step back par kinds - if(cnode_flags_set(callnode,call_flags,proc_run_shared)) then - coder%par_kind=coder%par_kind2 - endif ! For procedure signature "." call then don't check visibility - visible=present(sig_start) + ! .. also do not check visibility for yield(...) call + visible=present(sig_start).or.iand(flags,proccall_is_yield)/=0 ! Find matching signature ! This is done in multiple passes with increasingly broader matching @@ -2203,7 +2091,12 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) proc=cnode_arg(procs,i) if(debug_inference) write(*,*) 'CHECK nret',cnode_get_num(proc,pr_nret),nret,& 'amps',cnode_get_num(proc,pr_amps),amps,& - 'comm',cnode_flags_set(proc,pr_flags,proccall_is_comm),is_comm + 'comm',cnode_flags_set(proc,pr_flags,proccall_is_comm),is_comm,& + 'cflags',iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general),& + iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general) +!!$ call pm_dump_tree(coder%context,6,pm_name_val(coder%context,cnode_get_num(proc,pr_amps)),2) +!!$ call pm_dump_tree(coder%context,6,pm_name_val(coder%context,amps),2) + if(cnode_get_num(proc,pr_nret)/=nret) cycle if(cnode_get_num(proc,pr_amps)/=amps) cycle if(iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general)/=& @@ -2236,7 +2129,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) trim(pm_type_as_string(coder%context,pars)),'AFTER>',& trim(pm_type_as_string(coder%context,match_pars)) if(pm_type_includes(coder%context,pars,& - match_pars,pm_type_incl_type,einfo)) then + match_pars,pm_type_incl_type)) then coder%wtop=wbase coder%vtop=vbase ! Have to also check compatibility of return types @@ -2245,11 +2138,10 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) if(nret>0.and.rt>0.and.found_has_no_rtypes) then rt2=abs(cnode_get_num(proc,pr_rtype)) if(pm_type_kind(coder%context,rt2)/=pm_type_is_undef_result) then - if(.not.pm_type_includes(coder%context,rt2,rt,pm_type_incl_type,einfo)) then + if(.not.pm_type_includes(coder%context,rt2,rt,pm_type_incl_type)) then call inf_error(coder,proc,& 'Procedure returns type(s) not compatible'//& ' with an enclosing procedure to which it conforms') - call pm_type_error(coder%context,einfo) call inf_error(coder,cnode_arg(procs,i+1),& 'Enclosing procedure referenced in above error') call more_error(coder%context,' ') @@ -2260,10 +2152,10 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) endif if(pm_type_has_when(coder%context,pars)) then if(pm_type_includes(coder%context,match_pars,& - pars,pm_type_incl_type,einfo)) then + pars,pm_type_incl_type)) then ! Two equally specific when procs - the second must have when(false) coder%trace_depth=coder%trace_depth+1 - if(coder%trace_depth0) then if(rt>0) then rtvect=pm_type_vect(coder%context,rt) - if(pm_tv_kind(rtvect)==pm_type_is_tuple) then + if(pm_tv_kind(rtvect)==pm_type_is_tuple.and.& + iand(pm_tv_flags(rtvect),pm_type_is_list)==0) then do j=1,nret v=cnode_arg(args,j) call combine_types(v,& @@ -2392,7 +2285,9 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) elseif(.not.found.or..not.visible) then ! If nothing found print error message ! or return error flag - if(.not.present(err)) then + if(present(err)) then + err=.true. + elseif(iand(flags,proccall_is_yield)==0) then if(.not.found) then call cnode_error(coder,callnode,& 'No matching procedure returning '//trim(pm_int_as_string(nret))//' value'//& @@ -2431,7 +2326,9 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) enddo ressig=undefined else - err=.true. + call cnode_error(coder,callnode,'Yield statement does not conform to supplied block') + call print_call_details(coder,callnode,keybase,nargs) + call inf_trace(coder) endif else ! Otherwise create resolved procedure cnode @@ -2447,9 +2344,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) ! Tidy up coder%vtop=start - coder%par_kind=save_par_kind - coder%par_kind2=save_par_kind2 - + end function simple_proc_call !================================================ @@ -2463,8 +2358,6 @@ function var_call(callnode) result(ressig) integer:: proctyp,tno,name,start,arg(1) logical:: err - write(*,*) 'var call enter>',coder%wtop - ! Get value for procedure name (actually its type) var=cnode_get(callnode,call_var) if(cnode_get_kind(var)==cnode_is_var) then @@ -2565,7 +2458,7 @@ subroutine check_call_against_sig(tno,tvp,callnode) endif if(iand(pm_tv_flags(tv),pm_type_is_yield)/=0.neqv.& - cnode_flags_set(callnode,call_flags,proccall_is_yield)) then + cnode_flags_set(callnode,call_flags,proccall_is_block)) then call inf_error(coder,callnode,& 'Call does not match procedure type ("yield")'//& trim(pm_type_as_string(coder%context,tno))) @@ -2584,7 +2477,6 @@ subroutine check_returns_against_sig(tno,tvp,callnode) type(pm_ptr):: tv2 integer:: tno2,nret integer:: tno3,i,k,n,at - type(pm_type_einfo):: einfo nret=cnode_get_num(callnode,call_nret) @@ -2614,7 +2506,7 @@ subroutine check_returns_against_sig(tno,tvp,callnode) do i=1,n at=get_var_type(coder,callnode,cnode_arg(args,i)) if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& - at,pm_type_incl_val,einfo)) then + at,pm_type_incl_val)) then call inf_error(coder,callnode,& 'Call does not match procedure type: '//& @@ -2776,7 +2668,7 @@ function match_call_sig(coder,callnode,procnode,pars,& endif if(debug_inference) then - write(*,*) 'Check call sig: (' + write(*,*) 'Check call sig: [ipass=',ipass,'] (' write(*,*) pars,' ',trim(pm_type_as_string(coder%context,pars)) write(*,*) '----' do i=1,nargs @@ -2853,9 +2745,9 @@ end function match_call_sig ! Any conversions will result in conversion record pushed on vstack ! convesion record will refer to argument #ielem ! Conversions applied are determined by ipass - ! 0 -- lexical to basic - ! 1 -- proc type conversion - ! 2 -- embedded types + ! 0 -- none + ! 1 -- lexical to basic + ! 2 -- proc type conversion ! 3 -- convert to poly type !================================================================ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) result(new_at) @@ -2865,17 +2757,16 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) logical,intent(out):: nomatch,error integer:: new_at integer:: at,pt2,at2,base,status,flags - type(pm_type_einfo):: einfo at=old_at nomatch=.false. error=.false. flags=cnode_get_num(callnode,call_flags) if(iand(flags,call_is_fixed)==0) then - at2=pm_type_convert(coder%context,pt,at,.true.,.false.,.false.) + at2=pm_type_convert(coder%context,pt,at,.true.,ipass>=2,.false.) if(at2>0) at=at2 endif if(pm_type_includes(coder%context,& - pt,at,pm_type_incl_val,einfo)) then + pt,at,pm_type_incl_val)) then if(debug_inference) then write(*,*) 'Match',trim(pm_type_as_string(coder%context,pt)),'<>',& trim(pm_type_as_string(coder%context,at)) @@ -2883,78 +2774,34 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) new_at=at return else - if(einfo%kind==pm_type_err_ambig) then - call cnode_error(coder,procnode,& - 'Ambiguous match to proc definition ( match in multiple alternatives)') - call cnode_error(coder,callnode,'... call being processed') - error=.true. + at2=pm_type_convert(coder%context,pt,at,.true.,ipass>=2,.false.) + if(at2>0) then + new_at=at2 return - elseif(ipass>=1) then - pt2=pm_type_strip_to_basic(coder%context,pt) - at2=pm_type_convert(coder%context,pt,at,.false.,.true.,.false.) - if(at2/=undefined) then - new_at=at2 - return - endif - if(ipass==1) then - nomatch=.true. - return - elseif(ipass>=2) then + elseif(ipass==3) then + ! On third pass check for poly conversions + at2=convert_poly(coder,pt,at,.false.) + if(at2/=-1) then base=coder%wtop - ! Push index value for autoconv signature call push_word(coder,ielem) - ! Check indirect inclusion - call pm_indirect_include(coder%context,pt,at,coder%wstack,max_code_stack,& - coder%wtop,einfo,at2,status) - if(status/=pm_elem_not_found) then - if(status==pm_elem_clash) then - call ambiguous_match_error(coder,callnode,pt,at,at2) - error=.true. - coder%wtop=base - return - endif - ! Match with indirect inclusion - ! Make autoconv object - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - coder%wtop=base - ! Correct parameter type to post-conversion value - new_at=at2 - return - else - if(ipass==3) then - ! On third pass check for poly conversions - at2=convert_poly(coder,pt2,at,.false.) - if(at2/=-1) then - call push_word(coder,at2) - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - ! Correct parameter type to post-conversion value - coder%wtop=base - new_at=at2 - return - endif - endif - - ! No match found - if(debug_inference) then - write(*,*) 'Does not include',& - trim(pm_type_as_string(coder%context,pt)),'<>',& - trim(pm_type_as_string(coder%context,at)) - endif - nomatch=.true. - coder%wtop=base - return - endif - endif - else - ! No match found (pass 1) - if(debug_inference) then - write(*,*) 'Does not include',& - trim(pm_type_as_string(coder%context,pt)),'<>',& - trim(pm_type_as_string(coder%context,at)) + call push_word(coder,at2) + call code_int_vec(coder,coder%wstack,base+1,coder%wtop) + ! Correct parameter type to post-conversion value + coder%wtop=base + new_at=at2 + return endif - nomatch=.true. - return endif + + ! No match found + if(debug_inference) then + write(*,*) 'Does not include',& + trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) + endif + nomatch=.true. + !coder%wtop=base + return endif end function match_arg @@ -3047,7 +2894,6 @@ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) logical,intent(in):: conv_poly integer:: typ3 type(pm_ptr):: tv1,tv2 - type(pm_type_einfo):: einfo if(typ1<=0) return typ3=-1 tv1=pm_type_vect(coder%context,typ1) @@ -3056,7 +2902,7 @@ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) if(pm_tv_kind(tv2)==pm_type_is_poly) then if(conv_poly.and.pm_type_includes(coder%context,& pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_type_incl_type,einfo)) then + pm_type_incl_type)) then if(add_poly_to_poly(coder,typ1,typ2)) then coder%types_finished=.false. endif @@ -3065,7 +2911,7 @@ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) else if(pm_type_includes(coder%context,& pm_tv_arg(tv1,1),typ2,& - pm_type_incl_type,einfo)) then + pm_type_incl_type)) then if(add_type_to_poly(coder,typ1,typ2)) then coder%types_finished=.false. endif @@ -3181,6 +3027,7 @@ function get_var_type(coder,callnode,var,init) result(tno) type(pm_ptr),intent(in):: callnode,var logical,intent(in),optional:: init integer:: tno + integer:: tk tno=coder%stack(cnode_get_num(var,var_index)+coder%base) !!$ if(tno==undefined) then !!$ call cnode_error(coder,callnode,& @@ -3189,7 +3036,8 @@ function get_var_type(coder,callnode,var,init) result(tno) !!$ tno=error_type !!$ return !!$ endif - if(pm_type_kind(coder%context,tno)==pm_type_is_uninitialised) then + tk=pm_type_kind(coder%context,tno) + if(tk==pm_type_is_uninitialised) then if(present(init)) then if(init) then tno=pm_type_arg(coder%context,tno,1) @@ -3197,12 +3045,16 @@ function get_var_type(coder,callnode,var,init) result(tno) endif endif call cnode_error(coder,callnode,& - 'Attempt to use "var" or "const" value before it is initialised') + 'Attempt to use "var" or "const" value before it is initialised: ',& + cnode_get(var,var_name)) call cnode_error(coder,var,& 'Definition statement relating to above error') coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type tno=error_type - return + elseif(tk==pm_type_is_error) then + call inf_type_error(coder,callnode,tno,var) + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + tno=error_type endif end function get_var_type @@ -3280,19 +3132,6 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) end subroutine combine_var_type - ! =============================================================== - ! Error message for ambiguous match - ! (assumes wstack holds results from pm_indirect_include) - ! =============================================================== - subroutine ambiguous_match_error(coder,callnode,pt,at,at2) - type(code_state):: coder - type(pm_ptr):: callnode - integer,intent(in):: pt,at,at2 - call inf_error(coder,callnode,'Ambiguous match to embedded value:') - call pm_type_ambiguous_match_error(coder%context,pt,at,at2,coder%wstack,coder%wtop) - call inf_trace(coder) - end subroutine ambiguous_match_error - !=========================================================== ! Type constraint / Cast !=========================================================== @@ -3304,47 +3143,21 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) logical,intent(in):: isvar integer:: k logical:: ok - integer:: tno1b,tno3,base,status,key(1) - type(pm_type_einfo):: einfo + integer:: tno3,base,key(1) k=0 if(tno1<0.or.tno2<=0) then return endif - ok=pm_type_includes(coder%context,tno1,tno2,pm_type_incl_val,& - einfo) + ok=pm_type_includes(coder%context,tno1,tno2,pm_type_incl_val) if(.not.ok) then - tno1b=pm_type_strip_to_basic(coder%context,tno1) - tno3=pm_type_convert(coder%context,tno1b,tno2,.true.,.true.,.false.) + tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.true.,.false.) if(tno3==undefined) then base=coder%wtop - call pm_indirect_include(coder%context,tno1,tno2,& - coder%wstack,max_code_stack,coder%wtop,& - einfo,tno3,status) - if(status/=pm_elem_not_found) then - if(status==pm_elem_clash) then - call ambiguous_match_error(coder,node,tno1,tno2,tno3) - ok=.true. ! To supress error message - else - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - call make_code(coder,pm_null_obj,cnode_is_any_sig,1) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,pop_code(coder)) - tno2=tno3 - ok=.true. - endif - else - tno3=convert_poly(coder,tno1b,tno2,.true.) - if(tno3/=-1) then - call push_word(coder,tno3) - call code_int_vec(coder,coder%wstack,coder%wtop,coder%wtop) - call make_code(coder,pm_null_obj,cnode_is_any_sig,1) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,pop_code(coder)) - tno2=tno3 - ok=.true. - endif + tno3=convert_poly(coder,tno1,tno2,.true.) + if(tno3/=-1) then + k=tno3 + tno2=tno3 + ok=.true. endif coder%wtop=base else @@ -3355,7 +3168,6 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) if(.not.ok) then call inf_error(coder,node,& 'Value cannot be cast to the given type') - call pm_type_error(coder%context,einfo) call inf_trace(coder) endif contains @@ -3380,7 +3192,6 @@ function fold(coder,procnode,atype,rstype) result(rtype) character(len=100):: emess type(pm_ptr):: rtv integer:: rtyp - type(pm_type_einfo):: einfo tv=pm_type_vect(coder%context,atype) n=pm_tv_numargs(tv)-1 @@ -3389,16 +3200,16 @@ function fold(coder,procnode,atype,rstype) result(rtype) coder%temp=pm_fast_newnc(coder%context,pm_long,1) tno=pm_tv_arg(tv,2) tk=pm_type_kind(coder%context,tno) - if(tk/=pm_type_is_struct.and.tk/=pm_type_is_rec) then + if(tk/=pm_type_is_rec.and.tk/=pm_type_is_tuple) then call inf_error_with_trace(coder,procnode,& - 'Can only apply "elements" to a "struct" or "rec", not: '//& + 'Can only apply "num_elements" to a "rec", not: '//& pm_type_as_string(coder%context,tno)) num_elem=1 else num_elem=pm_type_numargs(coder%context,tno) endif coder%temp%data%ln(coder%temp%offset)=num_elem - rtype=pm_new_fix_type(coder%context,coder%temp) + rtype=pm_new_fix_value_type(coder%context,coder%temp) return elseif(opcode==op_type_include_fold) then ok=pm_type_includes(coder%context,& @@ -3406,7 +3217,7 @@ function fold(coder,procnode,atype,rstype) result(rtype) pm_type_arg(coder%context,atype,2),1),& pm_type_arg(coder%context,& pm_type_arg(coder%context,atype,3),1),& - pm_type_incl_type,einfo) + pm_type_incl_type) if(ok) then rtype=coder%true_literal else @@ -3432,17 +3243,17 @@ function fold(coder,procnode,atype,rstype) result(rtype) if(.not.ok) then call inf_error_with_trace(coder,procnode,& 'Cannot combine run time values: '//trim(emess)) - elseif(pm_tv_kind(rtv)==pm_type_is_unfixed) then - rtype=pm_new_literal_type(coder%context,coder%temp) + elseif(pm_tv_kind(rtv)==pm_type_is_literal) then + rtype=pm_new_literal_value_type(coder%context,coder%temp) else - rtype=pm_new_fix_type(coder%context,coder%temp) + rtype=pm_new_fix_value_type(coder%context,coder%temp) endif elseif(rtyp==pm_string_type) then call fold_string(coder,opcode,arg1,arg2,coder%temp) - if(pm_tv_kind(rtv)==pm_type_is_unfixed) then - rtype=pm_new_literal_type(coder%context,coder%temp) + if(pm_tv_kind(rtv)==pm_type_is_literal) then + rtype=pm_new_literal_value_type(coder%context,coder%temp) else - rtype=pm_new_fix_type(coder%context,coder%temp) + rtype=pm_new_fix_value_type(coder%context,coder%temp) endif else if(opcode==op_eq_fold.or.opcode==op_ne_fold) then @@ -3452,7 +3263,7 @@ function fold(coder,procnode,atype,rstype) result(rtype) else call fold_comparison(opcode,arg1,arg2,ok) endif - if(pm_tv_kind(rtv)==pm_type_is_unfixed) then + if(pm_tv_kind(rtv)==pm_type_is_literal) then if(ok) then rtype=coder%true_literal else @@ -3672,8 +3483,12 @@ subroutine inf_error(coder,node,message,name) lineno,& charno) if(present(name)) then - call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) + if(.not.pm_fast_isnull(name)) then + call pm_name_string(coder%context,int(name%offset),str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) + else + str=trim(pm_opts%error)//' '//message + endif else str=trim(pm_opts%error)//' '//message endif @@ -3687,8 +3502,24 @@ subroutine inf_error(coder,node,message,name) if(coder%num_errors>max_code_errors) then call pm_stop('Too many type inference errors - compilation terminated') endif + contains + include 'fisnull.inc' end subroutine inf_error + !=========================================================== + ! Output error message associated with given error type + !========================================================== + subroutine inf_type_error(coder,node,tno,var) + type(code_state):: coder + type(pm_ptr),intent(in):: node,var + integer,intent(in):: tno + type(pm_ptr):: tv + character(len=100):: str + call pm_strval(pm_type_val(coder%context,tno),str) + call inf_error(coder,node,trim(str)//': '//& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name)))) + end subroutine inf_type_error + ! ============================================================ ! Output trace of current call stack ! Calls stored in coder%trace(1:coder%trace_depth) @@ -3704,7 +3535,7 @@ subroutine inf_trace(coder) if(coder%supress_errors) return if(coder%trace_depth<1) return top=coder%trace_depth - if(pm_opts%hide_sysmod.and.top1) @@ -3724,7 +3555,7 @@ subroutine inf_trace(coder) write(*,*) write(*,*) '-------------CALL TRACE---------------------------' do k=top,1,-1 - if(k>max_par_depth) then + if(k>max_trace_depth) then write(*,*) 'Procedure call: (call not recorded)' cycle endif @@ -3836,10 +3667,12 @@ subroutine print_call_details(coder,node,base,numargs) dotchr=' ' endif - if(cnode_flags_set(node,call_flags,proccall_is_yield)) then + if(cnode_flags_set(node,call_flags,proccall_is_block)) then n=n+3 endif + if(pm_opts%show_hidden) n=0 + call more_error(coder%context,dotchr//trim(pm_name_as_string(coder%context,& signame))//procchr//' (') k=0 @@ -3870,7 +3703,7 @@ subroutine print_call_details(coder,node,base,numargs) trim(pm_type_as_string(coder%context,coder%wstack(base+i)))//join) enddo - if(cnode_flags_set(node,call_flags,proccall_is_yield)) then + if(cnode_flags_set(node,call_flags,proccall_is_block)) then call more_error(coder%context,' ) yield (') call more_error(coder%context,' '//& trim(pm_type_as_string(coder%context,coder%wstack(base+nkeys+2+n-2)))) @@ -3892,6 +3725,13 @@ subroutine check_amp(i) ampstr=' ' return endif + do while(amp%data%i(amp%offset+k)pm_fast_esize(amp)) then + ampstr=' ' + return + endif + enddo if(amp%data%i(amp%offset+k)==i) then ampstr=' &' k=k+1 @@ -3938,11 +3778,11 @@ subroutine print_proc_details(coder,node) nret=cnode_get_num(node,pr_nret) do i=1,nret-1 str(n:n+1)='_,' - n=n+1 + n=n+2 enddo if(nret>0) then str(n:n+1)='_=' - n=n+1 + n=n+2 endif if(cnode_flags_set(node,pr_flags,proccall_is_ref)) then @@ -3964,14 +3804,15 @@ subroutine print_proc_details(coder,node) else istart=2 endif - if(cnode_flags_set(node,pr_flags,proccall_is_yield)) istart=istart+3 + if(cnode_flags_set(node,pr_flags,proccall_is_block)) istart=istart+3 + if(pm_opts%show_hidden) istart=1 tno=cnode_get_num(node,pr_ptype) call pm_type_to_string(coder%context,tno,str,n,tuple_start=istart) n=n+1 if(n>len(str)-20) then str(n:n+2)='...' else - if(cnode_flags_set(node,pr_flags,proccall_is_yield)) then + if(cnode_flags_set(node,pr_flags,proccall_is_block)) then str(n:)=')yield(' n=n+7 tno=pm_type_arg(coder%context,tno,istart) diff --git a/src/opts.f90 b/src/opts.f90 index 14607dd..cc86b49 100755 --- a/src/opts.f90 +++ b/src/opts.f90 @@ -44,6 +44,7 @@ module pm_options logical:: check_alias logical:: show_all_ref logical:: print_immediate + logical:: show_hidden logical:: out_sysmod logical:: out_typelist @@ -88,6 +89,7 @@ subroutine init_opts(context) pm_opts%check_alias=.not.pm_is_compiling pm_opts%show_all_ref=.false. pm_opts%print_immediate=.false. + pm_opts%show_hidden=.false. pm_opts%out_sysmod=.false. pm_opts%out_typelist=.false. @@ -153,11 +155,6 @@ subroutine help write(*,*) ' -fno-inline Do not inline any procedures.' write(*,*) ' -fno-check Do not run "check" or "test" statements.' write(*,*) ' -fcheck Run "check" and "test" statements.' - write(*,*) ' -fshow-elems Show structure/record elements in error messages.' - write(*,*) ' -fshow-members Show members of user defined types in error messages' - write(*,*) ' -fshow-variants Show all variants for proc types' - write(*,*) ' -fsee-all-procs List all alternative procedures in error messages' - write(*,*) ' -fproc-list=n Maximum number of procs to list if see-all-procs not invoked' write(*,*) ' -fno-alias-check Do not check for argument aliasing' write(*,*) ' -falias_check Check for argument aliasing' if(.not.pm_is_compiling) then @@ -165,6 +162,14 @@ subroutine help write(*,*) ' Do not buffer print output by node' endif write(*,*) + write(*,*) ' ERROR OR TRACE OUTPUT OPTIONS' + write(*,*) ' -fshow-elems Show structure/record elements in error messages.' + write(*,*) ' -fshow-members Show members of user defined types in error messages' + write(*,*) ' -fshow-variants Show all variants for proc types' + write(*,*) ' -fshow-hidden Show hidden procedure parameters' + write(*,*) ' -fsee-all-procs List all alternative procedures in error messages' + write(*,*) ' -fproc-list=n Maximum number of procs to list if see-all-procs not invoked' + write(*,*) write(*,*) ' GENERAL OPTIONS' write(*,*) ' -N Do not colour-highlight error messages' write(*,*) ' -H Colour-highlight error messages' @@ -294,6 +299,8 @@ subroutine pm_get_command_line(context,mname) pm_opts%check_alias=.false. elseif(arg=='-fprint-immediate'.and..not.pm_is_compiling) then pm_opts%print_immediate=.true. + elseif(arg=='-fshow-hidden') then + pm_opts%show_hidden=.true. elseif(arg(1:12)=='-fproc-list=') then pm_opts%proc_list=get_num_opt(arg,arg(13:)) elseif(arg(3:4)=='tn') then diff --git a/src/parlib.f90 b/src/parlib.f90 index b21b456..de7a633 100644 --- a/src/parlib.f90 +++ b/src/parlib.f90 @@ -405,7 +405,7 @@ recursive subroutine broadcast(context,node,v,xcomm,xthis) call pm_ptr_assign(context,w,j,& broadcast_val(context,node,w%data%ptr(w%offset+j),nn,xcomm,xthis)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call broadcast(context,node,v%data%ptr(v%offset+i),xcomm,xthis) enddo @@ -501,7 +501,7 @@ recursive subroutine broadcast_disp(context,node,v,off,offstart,noff,xcomm) call pm_ptr_assign(context,avec,k,broadcast_val(context,& node,avec%data%ptr(avec%offset+k),nout,xcomm)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call broadcast_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,xcomm) enddo @@ -642,7 +642,7 @@ recursive function broadcast_val(context,node,v,nout,xcomm,xthis) result(ptr) broadcast_val(context,node,w%data%ptr(w%offset+j),nn,xcomm,xthis)) enddo call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) + case(pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) root=>pm_new_as_root(context,pm_usr,esize+1) ptr=root%ptr ptr%data%ptr(ptr%offset)%offset=tno @@ -818,7 +818,7 @@ recursive function broadcast_val_disp(context,off,offstart,noff,node,v,nout) res broadcast_val(context,node,w%data%ptr(w%offset+k),nn)) enddo call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) root=>pm_new_as_root(context,pm_usr,esize+1) ptr=root%ptr ptr%data%ptr(ptr%offset)%offset=tno @@ -991,7 +991,7 @@ recursive subroutine gather(context,v,w,j) broadcast_val(context,k,& v%data%ptr(v%offset+pm_array_vect),nn)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call gather(context,v%data%ptr(v%offset+i),w%data%ptr(w%offset+i),j) enddo @@ -1051,7 +1051,7 @@ recursive subroutine recv(context,node,v,mess_tag) do j=0,pm_fast_esize(len) call pm_ptr_assign(context,avec,j,recv_val(context,node,mess_tag+1)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,esize call recv(context,node,v%data%ptr(v%offset+i),mess_tag) enddo @@ -1141,7 +1141,7 @@ recursive subroutine recv_rest(context,node,v,mess_tag) do j=0,pm_fast_esize(avec) call pm_ptr_assign(context,avec,j,recv_val(context,node,mess_tag+1)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,esize call recv_rest(context,node,v%data%ptr(v%offset+i),mess_tag) enddo @@ -1191,7 +1191,7 @@ recursive subroutine recv_disp(context,node,v,off,offstart,noff,mess_tag) k=off%data%ln(off%offset+offstart+j) call pm_ptr_assign(context,avec,k,recv_val(context,node,mess_tag+1)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call recv_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -1290,7 +1290,7 @@ recursive subroutine recv_rest_disp(context,node,v,off,offstart,noff,mess_tag) call pm_ptr_assign(context,avec,k,recv_val(context,node,mess_tag+1)) enddo if(debug_mess) call pm_dump_tree(context,6,v,2) - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call recv_rest_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -1360,7 +1360,7 @@ recursive function recv_val(context,node,mess_tag) result(ptr) recv_val(context,node,mess_tag)) enddo call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) + case(pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) root=>pm_new_as_root(context,pm_usr,esize+1) ptr=root%ptr ptr%data%ptr(ptr%offset)%offset=tno @@ -1484,7 +1484,7 @@ recursive subroutine isend(node,v,mess_tag,xcomm) avec%data%ptr(avec%offset+j),& 0_pm_ln,-1_pm_ln,mess_tag+1,xcomm) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call isend(node,v%data%ptr(v%offset+i),mess_tag,xcomm) enddo @@ -1595,7 +1595,7 @@ recursive subroutine irecv(node,v,mess_tag,iserr,xcomm) case(pm_array_type,pm_const_array_type) iserr=.true. return - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call irecv(node,v%data%ptr(v%offset+i),mess_tag,iserr,xcomm) enddo @@ -1720,7 +1720,7 @@ recursive subroutine isend_val(node,v,start,siz,mess_tag,xcomm) off%data%ln(off%offset+j),& len%data%ln(len%offset+j),mess_tag,xcomm) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) + case(pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) do i=2,pm_fast_esize(v) call isend_val(node,v%data%ptr(v%offset+i),start,siz,mess_tag,xcomm) enddo @@ -1853,7 +1853,7 @@ recursive subroutine isend_val_disp(node,v,off,offstart,noff,mess_tag) avec%data%ptr(avec%offset+k),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call isend_val_disp(node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -1978,7 +1978,7 @@ recursive subroutine isend_disp(node,v,off,offstart,noff,mess_tag,xcomm) avec%data%ptr(avec%offset+k),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call isend_disp(node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -2126,7 +2126,7 @@ recursive subroutine irecv_disp(context,node,v,off,offstart,noff,mess_tag,partia call irecv_disp(context,node,& v%data%ptr(v%offset+pm_array_length),& off,offstart,noff,mess_tag,partial) - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call irecv_disp(context,node,v%data%ptr(v%offset+i),& off,offstart,noff,mess_tag,partial) @@ -2240,7 +2240,7 @@ recursive subroutine rsend(context,node,v,mess_tag) call isend_val(node,avec%data%ptr(avec%offset+j),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,esize call rsend(context,node,v%data%ptr(v%offset+i),mess_tag) enddo @@ -2333,7 +2333,7 @@ recursive subroutine rsend_disp(context,node,v,off,offstart,noff,mess_tag) call isend_val(node,avec%data%ptr(avec%offset+k),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call rsend_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo diff --git a/src/parser.f90 b/src/parser.f90 index e8d1003..ed82c41 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -59,7 +59,7 @@ module pm_parser integer:: ls,lineno,sym_lineno,name_lineno,old_sym_lineno logical:: newline,atstart integer:: n, sym_n, name_sym_n,old_sym_n, last, iunit - type(pm_ptr):: temp, lexval,single_amp + type(pm_ptr):: temp, lexval integer:: sym, pushback integer,dimension(max_parse_stack):: stack integer:: top @@ -124,10 +124,6 @@ subroutine init_parser(parser,context) .true.,.false.,ok) enddo - ! Create parser%si - call push_sym(parser,1) - call name_vector(parser,1) - parser%single_amp=pop_val(parser) contains include 'ftiny.inc' end subroutine init_parser @@ -435,9 +431,6 @@ subroutine scan(parser) case('/') c=getchar() sym=sym_open_square - case(':') - c=getchar() - sym=sym_open_smiley case default sym=sym_open end select @@ -492,9 +485,6 @@ subroutine scan(parser) case(':') c=getchar() sym=sym_dcolon - case(')') - c=getchar() - sym=sym_close_smiley case default sym=sym_colon end select @@ -519,12 +509,24 @@ subroutine scan(parser) sym=sym_gt endif case('<') - if(peekchar()=='=') then - c=getchar() - sym=sym_le - elseif(peekchar()=='<') then + if(peekchar()=='<') then c=getchar() sym=sym_open_attr + elseif(peekchar2()=='--') then + c=getchar() + c=getchar() + sym=sym_move + elseif(peekchar2()=='->') then + c=getchar() + c=getchar() + sym=sym_swap + elseif(peekchar2()=='==') then + c=getchar() + c=getchar() + sym=sym_move_all + elseif(peekchar()=='=') then + c=getchar() + sym=sym_le else sym=sym_lt endif @@ -952,6 +954,10 @@ subroutine skip_nested_comments(cc) c=getchar() do c=getchar() + if(c==pm_eof_char) then + call parse_error(parser,'End of file encountered inside "/* ... */"') + return + endif if(c=='*') then c=getchar() if(c=='/') then @@ -1213,11 +1219,12 @@ end function proccall !====================================================== ! Argument lists for procedure calls !====================================================== - recursive function arglist(parser,yield) result(iserr) + recursive function arglist(parser,yield,dot) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in),optional:: yield + type(pm_ptr),intent(in),optional:: dot logical:: iserr - integer m,n,base,sym,flags,line,pos + integer m,n,base,sym,msym,flags,line,pos type(pm_ptr):: temp iserr=.true. call get_sym_pos(parser,line,pos) @@ -1231,7 +1238,13 @@ recursive function arglist(parser,yield) result(iserr) flags=proccall_is_comm+proccall_is_general call scan(parser) elseif(present(yield)) then - flags=proccall_is_yield + if(yield) then + flags=proccall_is_yield + else + flags=proccall_is_block + endif + elseif(present(dot)) then + flags=proccall_is_comm+proccall_is_ref+proccall_is_general else flags=0 endif @@ -1271,7 +1284,10 @@ recursive function arglist(parser,yield) result(iserr) call make_node(parser,sym_name,1) m=m+3 endif - + elseif(present(dot)) then + call push_val(parser,dot) + m=m+1 + call push_sym(parser,m) endif if(expect(parser,sym_open)) return @@ -1287,7 +1303,11 @@ recursive function arglist(parser,yield) result(iserr) ! Call with no arguments if(parser%sym==sym_close) then call make_node(parser,sym_list,m) ! args - call push_null_val(parser) ! amps + if(parser%top>base) then ! amps + call name_vector(parser,base) + else + call push_null_val(parser) + endif call push_null_val(parser) ! keys call push_null_val(parser) ! key names call push_num_val(parser,flags) ! flags @@ -1317,25 +1337,32 @@ recursive function arglist(parser,yield) result(iserr) call scan(parser) exit else - if(check_name(parser,sym)) then - if(parser%sym==sym_assign) then - call make_node(parser,sym_list,m) - if(parser%top>base) then - call name_vector(parser,base) + if(parser%sym==sym_move.or.parser%sym==sym_move_all) then + msym=parser%sym + call scan(parser) + if(expr(parser)) return + call make_node(parser,msym,1) + else + if(check_name(parser,sym)) then + if(parser%sym==sym_assign) then + call make_node(parser,sym_list,m) + if(parser%top>base) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif + base=parser%top + call push_sym(parser,sym) + call scan(parser) + if(expr(parser)) return + n=1 + exit else - call push_null_val(parser) + call push_back(parser,sym) endif - base=parser%top - call push_sym(parser,sym) - call scan(parser) - if(expr(parser)) return - n=1 - exit - else - call push_back(parser,sym) endif + if(expr(parser)) return endif - if(expr(parser)) return m=m+1 endif if(parser%sym/=sym_comma) then @@ -1405,9 +1432,11 @@ recursive function qual(parser,dot_call) result(iserr) logical:: iserr integer:: sym,line,pos,n iserr=.true. + n=1 if(parser%sym==sym_pling) then call scan(parser) - call make_node(parser,sym_pling,1) + call make_node(parser,sym_pling,0) + n=n+1 endif do select case(parser%sym) @@ -1415,24 +1444,8 @@ recursive function qual(parser,dot_call) result(iserr) call get_sym_pos(parser,line,pos) call scan(parser) select case(parser%sym) - case(sym_caret) - call scan(parser) - if(parser%sym==sym_amp) then - call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node_at(parser,sym_get_dot_ref,2,line,pos) - else - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node_at(parser,sym_get_dot,2,line,pos) - endif - case(sym_open_square) - if(subscript(parser)) return - call make_node_at(parser,sym_dot_sub,2,line,pos) case(sym_open,sym_pct,sym_dash) + if(n>1) call make_node_at(parser,sym_reference,n,line,pos) call make_node_at(parser,sym_dot,1,line,pos) if(arglist(parser)) return if(present(dot_call)) then @@ -1440,32 +1453,53 @@ recursive function qual(parser,dot_call) result(iserr) iserr=.false. return endif + case(sym_open_brace) + call scan(parser) + if(expr(parser)) return + if(expect(parser,sym_close_brace)) return + if(parser%sym==sym_open) then + call scan(parser) + if(exprlist(parser,sym=sym_pm_list)) return + if(expect(parser,sym_close)) return + call make_node_at(parser,sym_open,2,line,pos) + else + call make_node_at(parser,sym_get_dot,1,line,pos) + endif + n=n+1 case default if(expect_name(parser)) return sym=parser%sym - if(sym==sym_open) then + if(sym==sym_dcolon) then call scan(parser) - if(parser%sym==sym_close) then - call make_node(parser,sym_list,0) - else - if(exprlist(parser)) return - endif + if(expect_name(parser)) return + call make_node(parser,sym_proc,2) + if(expect(parser,sym_open)) return + if(exprlist(parser,sym=sym_pm_list)) return + call make_node(parser,sym_open,2) + if(expect(parser,sym_close)) return + elseif(sym==sym_open) then + call make_node(parser,sym_proc,1) + if(exprlist(parser,sym=sym_pm_list)) return + call make_node(parser,sym_open,2) if(expect(parser,sym_close)) return - call make_node(parser,sym_dot_call,3) else - call make_node_at(parser,sym_dot,2,line,pos) + call make_node_at(parser,sym_dot,1,line,pos) endif + n=n+1 end select case(sym_d1:sym_d7) call get_sym_pos(parser,line,pos) call push_sym_val(parser,parser%sym) - call make_node_at(parser,sym_dot,2,line,pos) + call make_node_at(parser,sym_dot,1,line,pos) call scan(parser) + n=n+1 case(sym_open_square) call get_sym_pos(parser,line,pos) if(subscript(parser)) return - call make_node_at(parser,sym_sub,2,line,pos) + call make_node_at(parser,sym_sub,1,line,pos) + n=n+1 case default + if(n>1) call make_node(parser,sym_reference,n) exit end select enddo @@ -1616,7 +1650,7 @@ end function op ! Structure expression new name { name=.. } ! Parse node contains full_type/ list_of_expr / name / tag !========================================================== - recursive function struct_gen(parser) result(iserr) + recursive function rec_gen(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr integer:: base,vbase,i,name,line,pos,line1,pos1,tag @@ -1666,9 +1700,9 @@ recursive function struct_gen(parser) result(iserr) call make_node_at(parser,sym_list,parser%vtop-vbase,line1,pos1) call name_vector(parser,base) call push_sym_val(parser,tag) - call make_node_at(parser,sym_struct,4,line1,pos1) + call make_node_at(parser,sym_rec,4,line1,pos1) iserr=.false. - end function struct_gen + end function rec_gen !====================================================== ! Tuple former @@ -1740,6 +1774,10 @@ recursive function term(parser,checkqual) result(iserr) enddo if(expect(parser,sym_close)) return call make_node(parser,sym_switch_expr,m) + case(sym_yield) + if(yield(parser,.true.)) return + case(sym_pm_yield) + if(yield(parser,.false.)) return case(sym_open) call scan(parser) if(expr(parser)) return @@ -1768,8 +1806,8 @@ recursive function term(parser,checkqual) result(iserr) if(tuple(parser)) return case(sym_open_brace) if(array_former(parser,sym_close_brace)) return - case(sym_new) - if(struct_gen(parser)) return + case(sym_rec) + if(rec_gen(parser)) return case(sym_present) call scan(parser) if(expect(parser,sym_open)) return @@ -1811,11 +1849,12 @@ recursive function term(parser,checkqual) result(iserr) if(typ(parser)) return if(expect(parser,sym_gt)) return call make_node(parser,sym_type_val,1) - case(sym_open_smiley) + case(sym_pm_list) call scan(parser) + if(expect(parser,sym_open)) return if(exprlist(parser,m,nolist=.true.)) return - if(expect(parser,sym_close_smiley)) return - call make_node(parser,sym_open_smiley,m) + if(expect(parser,sym_close)) return + call make_node(parser,sym_pm_list,m) case(sym_fix) call scan(parser) if(parser%sym==sym_open_square) then @@ -1921,6 +1960,16 @@ recursive function term(parser,checkqual) result(iserr) return endif call make_node(parser,sym,m) + case(sym_pm_each_index) + call scan(parser) + if(expect(parser,sym_open)) return + if(expect_name(parser)) return + if(expect(parser,sym_in)) return + if(expr(parser)) return + if(expect(parser,sym_colon)) return + if(expr(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_pm_each_index,3) case default if(check_name_pos(parser,name,line,pos)) then select case(parser%sym) @@ -1935,6 +1984,13 @@ recursive function term(parser,checkqual) result(iserr) parser%sym==sym_pct.or.parser%sym==sym_dash) then if(arglist(parser)) return endif + case(sym_dot,sym_open_square,sym_d1:sym_d7,sym_at) + call push_name_val_at(parser,name,line,pos) + call make_node(parser,sym_name,1) + dot_call=.false. + if(qual(parser,dot_call)) return + iserr=.false. + return case default call push_name_val_at(parser,name,line,pos) call make_node(parser,sym_name,1) @@ -1955,6 +2011,27 @@ recursive function term(parser,checkqual) result(iserr) include 'fvkind.inc' end function term + ! ========================================= + ! Yield statement or expression + ! ========================================= + recursive function yield(parser,isyield) result(iserr) + type(parse_state),intent(inout):: parser + logical,intent(in):: isyield + logical:: iserr + iserr=.true. + call scan(parser) + call push_name_val(parser,sym_block_proc) + call make_node(parser,sym_name,1) + call make_node(parser,sym_dot,1) + call push_back(parser,sym_dash) + if(isyield) then + if(arglist(parser,yield=.true.)) return + else + if(arglist(parser)) return + endif + iserr=.false. + end function yield + !====================================================== ! Expression @@ -2216,12 +2293,13 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr type(parse_state),intent(inout):: parser logical,intent(in):: call_ok,assign_ok,define_ok logical:: iserr - integer:: n,nu,name - logical:: dotcall,must_be_assignment + integer:: n,nu,name,sym + logical:: dotcall,must_be_assignment,cannot_be_move iserr=.true. n=0 nu=0 must_be_assignment=.false. + cannot_be_move=.false. ! ( name [ qual ] | _ )* do @@ -2233,10 +2311,6 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr if(parser%sym/=sym_comma) exit call scan(parser) cycle - elseif(parser%sym==sym_open_smiley) then - n=n+1 - must_be_assignment=.true. - if(valref(parser)) return else n=n+1 if(expect_name(parser)) return @@ -2289,27 +2363,40 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr call make_node(parser,sym_proc,1) call make_node(parser,sym_lt,2) call scan(parser) - must_be_assignment=.true. + must_be_assignment=.true. + cannot_be_move=.true. case(sym_open_brace) call scan(parser) if(expr(parser)) return if(expect(parser,sym_close_brace)) return call make_node(parser,sym_lt,2) must_be_assignment=.true. + cannot_be_move=.true. end select if(parser%sym/=sym_comma) exit call scan(parser) enddo - call make_node(parser,sym_assign,n) - if(expect(parser,sym_assign)) return + sym=parser%sym + if(sym==sym_move.or.sym==sym_move_all.or.sym==sym_swap) then + if(n/=1) then + call parse_error(parser,'Cannot have multiple left hand sides before "'//trim(sym_names(sym))//'"') + elseif(cannot_be_move) then + call parse_error(parser,'Cannot have operators before "'//trim(sym_names(sym))//'"') + endif + call scan(parser) + if(valref(parser)) return + call make_node(parser,sym,2) + else + call make_node(parser,sym_assign,n) + if(expect(parser,sym_assign)) return - if(must_be_assignment.and..not.assign_ok) then - call parse_error(parser,'Cannot have an assignment in this context') + if(must_be_assignment.and..not.assign_ok) then + call parse_error(parser,'Cannot have an assignment in this context') + endif + if(rhs(parser,n)) return + call make_node(parser,sym_assign,2) endif - if(rhs(parser,n)) return - call make_node(parser,sym_assign,2) - iserr=.false. end function assn_or_call @@ -2323,8 +2410,14 @@ recursive function rhs(parser,n) result(iserr) integer:: name logical:: dotcall iserr=.true. - - if(n==1) then + + if(parser%sym==sym_do) then + if(do_stmt(parser)) return + elseif(parser%sym==sym_yield) then + if(yield(parser,.true.)) return + elseif(parser%sym==sym_pm_yield) then + if(yield(parser,.false.)) return + elseif(n==1) then if(expr(parser)) return else if(check_name(parser,name)) then @@ -2335,12 +2428,8 @@ recursive function rhs(parser,n) result(iserr) call make_node(parser,sym_name,1) dotcall=.false. if(qual(parser,dotcall)) return - if(.not.dotcall) then - call make_node(parser,sym_assign,1) - endif + call make_node(parser,sym_assign,1) endif - elseif(parser%sym==sym_do) then - if(do_stmt(parser)) return elseif(parser%sym==sym_number.or.parser%sym==sym_string.or.parser%sym==sym_dcolon) then if(term(parser,.false.)) return call make_node(parser,sym_assign,1) @@ -2361,36 +2450,24 @@ recursive function valref(parser) result(iserr) integer:: n iserr=.true. n=0 - if(parser%sym==sym_open_smiley) then + if(parser%sym==sym_caret) then call scan(parser) - do - if(valref(parser)) return - n=n+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - if(expect(parser,sym_close_smiley)) return - if(n>1) call make_node(parser,sym_open_smiley,n) + if(expect(parser,sym_open)) return + if(expr(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_caret,1) else - if(parser%sym==sym_caret) then + if(expect_name(parser)) return + if(parser%sym==sym_dcolon) then call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_caret,1) - else if(expect_name(parser)) return - if(parser%sym==sym_dcolon) then - call scan(parser) - if(expect_name(parser)) return - call make_node(parser,sym_use,2) - else - call make_node(parser,sym_name,1) - end if - endif - n=n+1 - if(qual(parser)) return - end if + call make_node(parser,sym_use,2) + else + call make_node(parser,sym_name,1) + end if + endif + n=n+1 + if(qual(parser)) return iserr=.false. end function valref @@ -2438,6 +2515,22 @@ function subexpr(parser) result(iserr) enddo call make_node(parser,sym_check,n) endif + do while(parser%sym==sym_distinct) + call scan(parser) + m=0 + do + if(expect_name(parser)) return + if(expect(parser,sym_assign)) return + if(valref(parser)) return + m=m+2 + if(parser%sym==sym_comma) then + call scan(parser) + else + exit + endif + enddo + call make_node(parser,sym_distinct,m+1) + end do do while(parser%sym==sym_where) call scan(parser) m=0 @@ -2455,8 +2548,7 @@ function subexpr(parser) result(iserr) call scan(parser) enddo if(expect(parser,sym_assign)) return - call push_null_val(parser) - call make_node(parser,sym_const,n+1) + call make_node(parser,sym_where,n) if(rhs(parser,n)) return call make_node(parser,sym_assign,2) m=m+1 @@ -2598,8 +2690,28 @@ recursive function do_stmt(parser) result(is_err) call push_null_val(parser) endif if(arglist(parser,yield=.false.)) return - if(block_or_single_stmt(parser,sym_do,0,line)) return - call make_node(parser,sym_do_stmt,4) + if(parser%sym==sym_colon) then + call scan(parser) + if(parser%sym==sym_return) then + call scan(parser) + call push_null_val(parser) + call xexprlist(parser) + else + call stmt_list(parser,single=.true.) + call push_null_val(parser) + endif + else + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(parser%sym==sym_return) then + call scan(parser) + call xexprlist(parser) + else + call push_null_val(parser) + endif + if(close_block(parser,sym_do,0,line)) return + endif + call make_node(parser,sym_do_stmt,5) end if is_err=.false. end function do_stmt @@ -2621,21 +2733,21 @@ recursive function for_each_stmt(parser,name) result(is_err) call scan(parser) endif if(iter(parser,.false.,var_name)) return - if(subexpr(parser)) return if(parser%sym==sym_while) then call scan(parser) - call xexpr(parser) + if(expr(parser)) return call make_node(parser,sym_while,1) elseif(parser%sym==sym_until) then call scan(parser) - call xexpr(parser) + if(expr(parser)) return call make_node(parser,sym_until,1) else call push_null_val(parser) endif + call push_null_val(parser) + if(subexpr(parser)) return if(block_or_single_stmt(parser,name,var_name,line)) return - call push_sym_val(parser,name) ! Make for-each node: iter while-until block label call make_node(parser,sym,4) is_err=.false. @@ -2683,11 +2795,11 @@ end function if_stmt !============================================================== ! (var | const) { name | _ } [ : type ] [ = expr ] !============================================================== - recursive function var_stmt(parser,moded_stmt) result(iserr) + recursive function var_stmt(parser,mode) result(iserr) type(parse_state),intent(inout):: parser - integer,intent(in),optional:: moded_stmt + integer,intent(in),optional:: mode logical:: iserr - integer:: n,nu,ne,sym,symi + integer:: n,nu,ne,sym logical:: dotcall iserr=.true. sym=parser%sym @@ -2712,47 +2824,100 @@ recursive function var_stmt(parser,moded_stmt) result(iserr) enddo if(parser%sym==sym_colon) then call scan(parser) + if(present(mode)) then + call push_sym_val(parser,mode) + else + call push_null_val(parser) + endif if(typ(parser)) return else + if(present(mode)) then + call push_sym_val(parser,mode) + else + call push_null_val(parser) + endif call push_null_val(parser) endif - call make_node(parser,sym,n+1) + call make_node(parser,sym,n+2) if(ne==n) then call parse_error(parser,& - 'A "'//trim(sym_names(sym))//'" statement must define at least one object') + 'A "'//trim(sym_names(sym))//& + '" statement must define at least one object') endif if(parser%sym==sym_assign) then call scan(parser) if(rhs(parser,n)) return call make_node(parser,sym_assign,2) if(subexpr(parser)) return - elseif(present(moded_stmt)) then - call parse_error(parser,'Must include an initialising expression in a "'//& - sym_names(moded_stmt)//' statement') + elseif(present(mode)) then + call parse_error(parser,'"'//trim(sym_names(mode))//' var" must have an initialiser') elseif(nu+ne>0) then - call parse_error(parser,'Cannot have "_" in unitialised '//& - trim(sym_names(sym))//' declaration') + call parse_error(parser,'Cannot have "_" in unitialised "'//& + trim(sym_names(sym))//'" declaration') endif iserr=.false. end function var_stmt !============================================================== - ! ( coherent | mirrored | shared ) [ var | const ] name = expr - ! ( coherent | shared) call + ! ( shrd | invar | chan ) block + ! ( shrd | invar | nhd | chan ) var ... !============================================================== - recursive function mode_stmt(parser,sym) result(iserr) + recursive function mode_stmt(parser) result(iserr) type(parse_state),intent(inout):: parser - integer,intent(in):: sym logical:: iserr + integer:: line,sym iserr=.true. -!!$ if(parser%sym==sym_var.or.parser%sym==sym_const) then -!!$ if(var_stmt(parser,moded_stmt=sym)) return -!!$ call make_node(parser,sym_list,1) -!!$ call push_sym_val(parser,sym) -!!$ call make_node(parser,sym_mode,2) + line=get_sym_line(parser) + sym=parser%sym + call scan(parser) + if(parser%sym==sym_var) then + if(var_stmt(parser,sym)) return + else + if(sym==sym_nhd) then + if(expect(parser,sym_var)) return + else + if(par_attr(parser,sym_distr,sym_block,sym)) return + call push_null_val(parser) + if(subexpr(parser)) return + if(block_or_single_stmt(parser,sym,0,line)) return + call make_node(parser,sym,3) + endif + endif iserr=.false. end function mode_stmt + !========================================================== + ! all ref [ op ] = expr [ subexpr ] + !========================================================== + recursive function all_stmt(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + iserr=.true. + call scan(parser) + if(valref(parser)) return + select case(parser%sym) + case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,& + sym_amp,sym_bar,sym_tilde,sym_concat) + call push_sym_val(parser,parser%sym) + call make_node(parser,sym_proc,1) + call scan(parser) + if(expect(parser,sym_assign)) return + case(sym_open_brace) + call scan(parser) + if(expr(parser)) return + if(expect(parser,sym_close_brace)) return + case(sym_assign) + call make_node(parser,sym_null,0) + case default + if(expect(parser,sym_assign)) return + end select + if(expr(parser)) return + call push_null_val(parser) + if(subexpr(parser)) return + call make_node(parser,sym_all,4) + iserr=.false. + end function all_stmt + !========================================================== ! switch [ xexpr ] { case xexprlist : statement_list ... } !========================================================== @@ -2876,16 +3041,16 @@ recursive function for_stmt(parser) result(iserr) else call push_null_val(parser) endif - call swap_vals(parser) + call push_null_val(parser) if(subexpr(parser)) return - call push_sym_val(parser,sym) - if(block_or_single_stmt(parser,sym_for,name,line)) return - call make_node(parser,sym_for,4) + if(block_or_single_stmt(parser,sym,name,line)) return + ! attr iter block + call make_node(parser,sym,4) iserr=.false. end function for_stmt !==================================================================================== - ! par [ << attrs >> ] { statements ( do name [ << attrs >> ] : statements ...) } + ! par [ << attrs >> ] { statements ( task name [ << attrs >> ] : statements ...) } !==================================================================================== recursive function par_stmt(parser) result(is_error) type(parse_state),intent(inout):: parser @@ -2990,15 +3155,18 @@ recursive function iter(parser,star_ok,first_name) result(iserr) integer,intent(out),optional:: first_name logical:: iserr integer:: i,m,name - logical:: star + logical:: star,amp iserr=.true. m=0 do - if(parser%sym==sym_mult) then + star=.false. + amp=.false. + if(parser%sym==sym_mult.and.star_ok) then call scan(parser) star=.true. - else - star=.false. + elseif(parser%sym==sym_amp) then + call scan(parser) + amp=.true. endif if(check_name(parser,name)) then call push_name_val(parser,name) @@ -3006,6 +3174,8 @@ recursive function iter(parser,star_ok,first_name) result(iserr) if(expect(parser,sym_in)) return if(star) then call make_node(parser,sym_mult,1) + elseif(amp) then + call make_node(parser,sym_amp,1) endif if(expr(parser)) return m=m+1 @@ -3027,9 +3197,8 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) integer,intent(in):: start,finish integer,intent(inout),optional:: sym logical:: iserr - integer:: n,i,base,vbase,vbase2,name,high + integer:: i,base,vbase,name,high iserr=.true. - n=0 base=parser%top vbase=parser%vtop high=max(sym_block,finish) @@ -3040,39 +3209,15 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) call scan(parser) if(expect(parser,sym_assign)) return if(expr(parser)) return - n=n+1 if(parser%sym/=sym_comma) exit call scan(parser) enddo if(expect(parser,sym_close_attr)) return enddo - if(parser%error_count==0.and.(n>0.or.start==sym_block)) then - vbase2=parser%vtop - do i=start,high - call make_node(parser,sym_null,0) - enddo - do i=1,n - name=parser%stack(base+i) - if(name>=start.and.& - name<=finish) then - name=name-start+1 - if(node_sym(parser%vstack(vbase+i))/=sym_null) then - parser%vstack(vbase2+name)=parser%vstack(vbase+i) - else - call parse_error(parser,'Repeated "<<'//& - trim(pm_name_as_string(parser%context,& - name+start-1))//'>>" attribute') - endif - else - call parse_error(parser,'Not an allowed attribute: "<<'//& - trim(pm_name_as_string(parser%context,& - name))//'=>>"') - endif - enddo - call make_node(parser,sym_list,high-start+1) - parser%top=base - parser%vstack(vbase+1)=top_val(parser) - parser%vtop=vbase+1 + if(parser%vtop>vbase) then + call make_node(parser,sym_list,parser%vtop-vbase) + call name_vector(parser,base) + call make_node(parser,sym_open_attr,2) else call push_null_val(parser) endif @@ -3122,6 +3267,52 @@ recursive function test_stmt(parser) result(iserr) iserr=.false. end function test_stmt + !====================================================== + ! over expr [ attr ] [ subexp ] block + !====================================================== + function over_stmt(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + integer:: line + iserr=.true. + line=get_sym_line(parser) + call scan(parser) + if(expr(parser)) return + if(par_attr(parser,sym_block,sym_block)) return + call push_null_val(parser) + if(subexpr(parser)) return + if(block_or_single_stmt(parser,sym_over,0,line)) return + call make_node(parser,sym_over,4) + iserr=.false. + end function over_stmt + + !====================================================== + ! sync [ while ] name [ block ] + !====================================================== + function sync_stmt(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + integer:: line,name + iserr=.true. + line=get_sym_line(parser) + call scan(parser) + if(parser%sym==sym_while) then + call scan(parser) + if(expect_and_get_name(parser,name)) return + if(block_or_single_stmt(parser,sym_sync,name,line)) return + call make_node(parser,sym_sync_while,2) + else + if(expect_and_get_name(parser,name)) return + if(parser%sym==sym_open_brace.or.parser%sym==sym_colon) then + if(block_or_single_stmt(parser,sym_sync,name,line)) return + else + call push_null_val(parser) + endif + call make_node(parser,sym_sync,2) + endif + iserr=.false. + end function sync_stmt + !====================================================== ! List of statements !====================================================== @@ -3135,6 +3326,7 @@ recursive subroutine stmt_list(parser,single) do sym=parser%sym select case(sym) + ! These statements are only used internally by the compiler case(sym_pm_send:sym_pm_serve) if(send_stmt()) goto 999 @@ -3148,9 +3340,29 @@ recursive subroutine stmt_list(parser,single) if(pm_do_stmt()) goto 999 case(sym_pm_head_node) if(head_node_stmt()) goto 999 + case(sym_pm_each_index) + if(each_index_stmt()) goto 999 + case(sym_pm_for,sym_pm_foreach,sym_pm_over) + if(pm_for_stmt()) goto 999 + case(sym_pm_context) + if(pm_context_stmt()) goto 999 + case(sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) + call scan(parser) + if(expect(parser,sym_open_brace)) goto 999 + call stmt_list(parser) + if(expect(parser,sym_close_brace)) goto 999 + call make_node(parser,sym,1) + case(sym_pm_set_dotdotdot) + call scan(parser) + if(expect(parser,sym_open)) goto 999 + if(expr(parser)) goto 999 + if(expect(parser,sym_close)) goto 999 + call make_node(parser,sym_pm_set_dotdotdot,1) + ! Pragma's -- start with $$ case(sym_ddollar) - if(pragma()) goto 999 + if(pragma()) goto 999 + ! Statements that are actually part of the language case(sym_if) if(if_stmt(parser)) goto 999 @@ -3164,73 +3376,52 @@ recursive subroutine stmt_list(parser,single) if(do_stmt(parser)) goto 999 case(sym_test) if(test_stmt(parser)) goto 999 - case(sym_for,sym_conc) + case(sym_for,sym_forall) if(for_stmt(parser)) goto 999 - case(sym_each,sym_foreach_invar) + case(sym_each) if(for_each_stmt(parser,0)) goto 999 case(sym_par) if(par_stmt(parser)) goto 999 case(sym_any) if(any_stmt(parser)) goto 999 + case(sym_all) + if(all_stmt(parser)) goto 999 case(sym_over) - line=get_sym_line(parser) - call scan(parser) - call xexpr(parser) - if(par_attr(parser,sym_block,sym_block)) goto 999 - if(block_or_single_stmt(parser,sym_over,0,line)) goto 999 - call make_node(parser,sym_over,3) - case(sym_with) - line=get_sym_line(parser) - call scan(parser) - if(assn_or_call(parser,.false.,.false.,.true.)) goto 999 - if(parser%sym==sym_check.or.parser%sym==sym_where) then - if(subexpr(parser)) goto 999 - endif - call make_node(parser,sym_list,1) - if(block_or_single_stmt(parser,sym_with,0,line)) goto 999 - call make_node(parser,sym_with,2) - case(sym_underscore,sym_open_smiley) + if(over_stmt(parser)) goto 999 + case(sym_underscore) if(assn_or_call(parser,.false.,.true.,.true.)) goto 999 - if(parser%sym==sym_check.or.parser%sym==sym_where) then - if(subexpr(parser)) goto 999 - endif + if(subexpr(parser)) goto 999 case(sym_var,sym_const) if(var_stmt(parser)) goto 999 if(subexpr(parser)) goto 999 - case(sym_invar,sym_local,sym_chan) - call scan(parser) - if(mode_stmt(parser,sym)) goto 999 + case(sym_invar,sym_chan,sym_nhd,sym_shared) + if(mode_stmt(parser)) goto 999 case(sym_dollar) if(proc_val_call()) goto 999 case(sym_proceed) call scan(parser) call make_node(parser,sym_proceed,0) case(sym_sync) - if(sync_assign()) goto 999 + if(sync_stmt(parser)) goto 999 case(sym_return) call make_node(parser,sym_list,k) return - case(sym_yield) - call scan(parser) - call push_name_val(parser,sym_block_proc) - call make_node(parser,sym_name,1) - call make_node(parser,sym_dot,1) - call push_back(parser,sym_dash) - if(arglist(parser,yield=.true.)) goto 999 + case(sym_yield,sym_pm_yield) + if(yield(parser,sym==sym_yield)) goto 999 call make_node(parser,sym_yield,1) case default if(parser%sym>num_sym) then if(assn_or_call(parser,.true.,.true.,.true.)) goto 999 if(subexpr(parser)) goto 999 else - if(parser%sym>0.and.parser%sym/=sym_close_brace& - .and.parser%sym<=last_decl) then - call parse_error(parser,'Expected start of statement') - goto 999 - else - exit - endif - endif + if(parser%sym>0.and.parser%sym/=sym_close_brace& + .and.parser%sym<=last_decl) then + call parse_error(parser,'Expected start of statement') + goto 999 + else + exit + endif + endif end select k=k+1 if(present(single)) exit @@ -3254,32 +3445,6 @@ recursive subroutine stmt_list(parser,single) contains - ! sync name [ qual ] = expr - function sync_assign() result(iserr) - logical:: iserr - iserr=.true. - call scan(parser) - if(expect_name(parser)) return - call make_node(parser,sym_name,1) - call dup_val(parser) - if(qual(parser)) return - select case(parser%sym) - case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_tilde,sym_concat) - call push_sym_val(parser,parser%sym) - call make_node(parser,sym_proc,1) - call scan(parser) - if(expect(parser,sym_assign)) return - if(expr(parser)) return - call make_node(parser,sym_sync_assign,4) - case default - if(expect(parser,sym_assign)) return - if(expr(parser)) return - call make_node(parser,sym_sync_assign,3) - end select - if(subexpr(parser)) return - iserr=.false. - end function sync_assign - ! $op(args) or $op.(args) function proc_val_call() result(iserr) logical:: iserr @@ -3295,7 +3460,7 @@ function proc_val_call() result(iserr) if(subexpr(parser)) return iserr=.false. end function proc_val_call - + ! Pragma: $$ name [ '(' exprlist ')' ] function pragma() result(iserr) logical:: iserr @@ -3462,6 +3627,53 @@ recursive function head_node_stmt() result(iserr) call make_node(parser,sym_pm_head_node,1) iserr=.false. end function head_node_stmt + + function each_index_stmt() result(iserr) + logical:: iserr + iserr=.true. + call scan(parser) + if(expect_name(parser)) return + if(expect(parser,sym_in)) return + if(expr(parser)) return + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym_pm_each_index,3) + iserr=.false. + end function each_index_stmt + + ! PM__for PM__foreach PM__over + function pm_for_stmt() result(iserr) + logical:: iserr + integer:: sym + iserr=.true. + sym=parser%sym + call scan(parser) + call xexpr(parser) + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym,2) + iserr=.false. + end function pm_for_stmt + + function pm_context_stmt() result(iserr) + logical:: iserr + integer:: i + iserr=.true. + call scan(parser) + do i=1,num_comm_args + if(i>1) then + if(expect(parser,sym_comma)) return + endif + if(expect_name(parser)) return + enddo + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym_pm_context,num_comm_args+1) + iserr=.false. + end function pm_context_stmt end subroutine stmt_list @@ -3722,16 +3934,9 @@ recursive function typval(parser) result(iserr) call push_sym_val(parser,sym_dim1+m-1) call make_node(parser,sym_type,m+1) if(expect(parser,sym_close_square)) return - case(sym_open_smiley) + case(sym_pm_list) + call make_node(parser,sym_pm_list,0) call scan(parser) - if(opt_moded_typ_list(parser,m,varg)) return - if(varg) then - call make_node(parser,sym_dotdotdot,m) - else - call make_node(parser,sym_list,m) - endif - call make_node(parser,sym_open_smiley,1) - if(expect(parser,sym_close_smiley)) return case(sym_lt) call scan(parser) if(typ(parser)) return @@ -3802,7 +4007,7 @@ recursive function typval(parser) result(iserr) if(typ(parser)) return call make_node(parser,sym_contains,1) if(expect(parser,sym_close)) return - case(sym_pm_dref:sym_pm_ref) + case(sym_pm_dref:sym_pm_dref_any_slice) call scan(parser) m=sym_pm_dref-sym-1 call push_num_val(parser,m) @@ -3889,12 +4094,6 @@ end function typval !==================================================================== ! proc ( args... ) -> (type,type...) - ! - ! Also used in methods and method signatures - ! For a method signature tname and params must be present - ! For a method, tname, params and is_method must be present - ! -- in this case parameter names are parsed and - ! pushed onto the symbol stack !==================================================================== recursive function proctyp(parser,yield) result(iserr) type(parse_state):: parser @@ -3939,6 +4138,10 @@ recursive function proctyp(parser,yield) result(iserr) call scan(parser) call push_sym(parser,m) if(moded_typ(parser,iscomm,.false.)) return + elseif(sym==sym_var.or.sym==sym_const) then + call scan(parser) + if(moded_typ(parser,iscomm,.false.)) return + call make_node(parser,sym,1) else if(moded_typ(parser,iscomm,.false.)) return endif @@ -4066,7 +4269,6 @@ recursive function opt_moded_typ_list(parser,m,varg) result(iserr) m=0 do if(parser%sym==sym_comma.or.& - parser%sym==sym_close_smiley.or.& parser%sym==sym_dotdotdot) then call push_null_val(parser) else @@ -4091,7 +4293,7 @@ recursive function param_list(parser,iscomm) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: iscomm logical:: iserr - integer:: m,n,i,base,last,vbase,sym,name,numloop + integer:: m,n,i,base,last,vbase,sym,msym,name,numloop type(pm_ptr):: temp,dom base=parser%top iserr=.true. @@ -4201,6 +4403,17 @@ recursive function param_list(parser,iscomm) result(iserr) m=m+1 call push_sym(parser,m) if(arg_typ_with_mode(iscomm)) return + elseif(parser%sym==sym_var.or.parser%sym==sym_const) then + msym=parser%sym + call scan(parser) + if(expect_name(parser)) return + if(parser%sym==sym_colon) then + call scan(parser) + if(arg_typ_with_mode(iscomm)) return + else + call push_null_val(parser) + endif + call make_node(parser,msym,1) else if(check_name(parser,name)) then if(parser%sym==sym_assign) then @@ -4296,56 +4509,6 @@ end function arg_typ_with_mode end function param_list - !====================================================== - ! Specialised kind of communicating procedure - !====================================================== - function proc_comm_kinds(parser,flags) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(inout):: flags - logical:: iserr - iserr=.true. - do - select case(parser%sym) - case(sym_shared) - call set_flags(proc_run_shared) - call scan(parser) - case(sym_pm_node) - call set_flags(proc_run_local+proc_run_always) - call scan(parser) -!!$ case(sym_complete) -!!$ call set_flags(proc_run_complete) -!!$ call scan(parser) - case(sym_cond_attr) - call set_flags(proc_is_cond) - call scan(parser) - case(sym_uncond) - call set_flags(proc_is_uncond) - call scan(parser) - end select - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - if(iand(flags,proc_is_cond+proc_is_uncond)==& - proc_is_cond+proc_is_uncond) then - call parse_error(parser,& - 'Cannot have both "cond" and "uncond" together') - endif - iserr=.false. - contains - subroutine set_flags(new_flags) - integer,intent(in):: new_flags - if(iand(flags,proccall_is_comm)==0) then - call parse_error(parser,& - 'Can only apply "'//trim(sym_names(parser%sym))//& - '" to a communicating procedure') - endif - if(iand(flags,new_flags)/=0) then - call parse_error(parser,& - 'Cannot repeat "'//trim(sym_names(parser%sym))//'"') - endif - flags=ior(flags,new_flags) - end subroutine set_flags - end function proc_comm_kinds !====================================================== ! Procedure/call attributes @@ -4360,13 +4523,6 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) call scan(parser) do select case(parser%sym) - case(sym_always) - if(iscall) then - call parse_error(parser,& - '"always" is not a valid attribute for a call') - endif - call set_flags(proc_run_always) - call scan(parser) case(sym_inline) call set_flags(proccall_is_inline) call scan(parser) @@ -4394,10 +4550,8 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) subroutine set_flags(new_flags) integer,intent(in):: new_flags if(iand(flags,new_flags)/=0) then - if(.not.(iand(flags,proc_run_local)/=0.and.new_flags==proc_run_always)) then - call parse_error(parser,& - 'Cannot repeat attribute "'//trim(sym_names(parser%sym))//'"') - endif + call parse_error(parser,& + 'Cannot repeat attribute "'//trim(sym_names(parser%sym))//'"') endif flags=ior(flags,new_flags) end subroutine set_flags @@ -4437,7 +4591,7 @@ function proc_decl(parser) result(iserr) isref=.false. if(parser%sym==sym_dot) then call scan(parser) - flags=ior(flags,proccall_is_ref+proccall_is_comm) + flags=ior(flags,proccall_is_ref+proccall_is_comm+proccall_is_general) iscomm=.true. isref=.true. endif @@ -4511,9 +4665,6 @@ function proc_decl(parser) result(iserr) if(yield_clause()) return endif - ! Special kinds of comm proc - if(proc_comm_kinds(parser,flags)) goto 999 - ! Attributes if(parser%sym==sym_open_attr) then if(proc_call_attr(parser,.false.,flags)) goto 999 @@ -4695,15 +4846,16 @@ function yield_clause() result(iserr) call push_val(parser,node_arg(params,i*2)) enddo else + amps=pm_name_val(parser%context,int(amps%offset)) k=0 do i=first,n call push_val(parser,node_arg(params,i*2-1)) call push_val(parser,node_arg(params,i*2)) - m=m+1 if(amps%data%i(amps%offset+k)==i) then call push_sym(parser,m) k=min(k+1,pm_fast_esize(amps)) endif + m=m+1 enddo endif call make_node(parser,node_sym(params),n*2+num_comm_args) @@ -4765,8 +4917,9 @@ end function proc_decl !====================================================== ! Procedure signature (...)->... used for builtin procs !====================================================== - recursive function proc_sig(parser) result(iserr) + recursive function proc_sig(parser,iscomm) result(iserr) type(parse_state),intent(inout):: parser + logical,intent(in):: iscomm logical:: iserr integer:: m,n,base,name,sym type(pm_ptr):: temp @@ -4782,6 +4935,53 @@ recursive function proc_sig(parser) result(iserr) else call push_null_val(parser) endif + if(iscomm) then + call push_sym_val(parser,sym_outer) + m=m+1 + if(parser%sym==sym_outer) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_region) + m=m+1 + if(parser%sym==sym_topology) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_subregion) + m=m+1 + if(parser%sym==sym_subregion) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_here_in_tile) + m=m+1 + if(parser%sym==sym_here_in_tile) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_mask) + m=m+1 + if(parser%sym==sym_mask) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + endif if(parser%sym==sym_close) then call make_node(parser,sym_list,2) call push_null_val(parser) @@ -4822,7 +5022,7 @@ recursive function proc_sig(parser) result(iserr) endif if(moded_typ(parser,.true.,.false.)) return - + if(parser%sym==sym_dotdotdot) then call scan(parser) call make_node(parser,sym_dotdotdot,m*2) @@ -4865,7 +5065,7 @@ recursive function proc_sig(parser) result(iserr) sym=parser%sym select case(sym) case(sym_gt,sym_dim,sym_vdim,sym_invar_dim,sym_fix_dim,& - sym_eq,sym_over,sym_pling,sym_includes) + sym_eq,sym_over,sym_pling,sym_includes) ! These return single type based on types of a ! list of expressions call scan(parser) @@ -4971,7 +5171,7 @@ function intrinsic(parser) result(iserr) if(parser%sym==sym_dot) then call scan(parser) - flags=ior(flags,proccall_is_comm+proccall_is_ref) + flags=ior(flags,proccall_is_comm+proccall_is_general+proccall_is_ref) endif if(.not.check_name(parser,name)) then @@ -5005,7 +5205,7 @@ function intrinsic(parser) result(iserr) call push_val(parser,parser%modl) ! module call push_num_val(parser,flags) ! flags if(expect(parser,sym_open)) goto 999 - if(proc_sig(parser)) return + if(proc_sig(parser,iand(flags,proccall_is_comm)/=0)) return if(expect(parser,sym_colon)) goto 999 if(expect(parser,sym_string)) goto 999 @@ -5022,6 +5222,9 @@ function intrinsic(parser) result(iserr) if(expect(parser,sym_number)) goto 999 opcode2=parser%lexval%data%ln(parser%lexval%offset) if(expect(parser,sym_close)) goto 999 + elseif(parser%sym>=first_mode.and.parser%sym<=last_mode) then + opcode2=parser%sym + call scan(parser) else opcode2=0 endif @@ -5087,7 +5290,7 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) call push_val(parser,parser%modl) ! module call push_num_val(parser,flags) ! flags if(expect(parser,sym_open)) goto 999 - if(proc_sig(parser)) return + if(proc_sig(parser,iand(flags,proccall_is_comm)/=0)) return call push_num_val(parser,int(opcode)) call push_num_val(parser,int(opcode2)) call push_val(parser,pdata) @@ -5185,8 +5388,8 @@ function typ_decl(parser) result(iserr) if(parser%sym==sym_is) then sym=sym_is call scan(parser) - if(parser%sym==sym_struct.or.parser%sym==sym_rec) then - if(structrec(parser,params,basename,name,m)) goto 999 + if(parser%sym==sym_rec) then + if(rec(parser,params,basename,name,m)) goto 999 call make_node(parser,sym_list,1) m=1 elseif(parser%sym==sym_unique) then @@ -5408,13 +5611,13 @@ end function unique !====================================================== ! Structure or record declaration !====================================================== - recursive function structrec(parser,params,basename,typname,nargs) result(iserr) + recursive function rec(parser,params,basename,typname,nargs) result(iserr) type(parse_state),intent(inout):: parser type(pm_ptr),intent(in):: params integer,intent(in):: basename,typname,nargs logical:: iserr integer:: i,tag,name,sym,base,vbase,line,pos,n,flags - logical:: hasuse + logical:: hasvar type(pm_ptr):: p iserr=.true. call make_qualified_name(parser,basename) @@ -5425,6 +5628,7 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) base=parser%top vbase=parser%vtop flags=0 + hasvar=.false. if(parser%sym==sym_caret) then call scan(parser) flags=pm_type_is_soa @@ -5432,33 +5636,35 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) if(parser%sym==sym_open_brace) then call scan(parser) else - if(parser%sym==sym_dotdotdot) then + if(parser%sym==sym_var) then + hasvar=.true. call scan(parser) else call parse_error(parser,& - 'Expected "{" or "..."') + 'Expected "{" or "var"') endif if(expect(parser,sym_open_brace)) return endif call push_sym(parser,tag) - hasuse=.false. n=0 do - if(parser%sym==sym_use) then + if(parser%sym==sym_var) then + if(hasvar) then + call parse_error(parser,'Cannot have "var" element in "rec var{...}"') + endif call scan(parser) if(check_name_no_repeat(parser,name,base+1)) then call push_sym(parser,-name) - hasuse=.true. else call parse_error(parser,& - 'Expected name of '//sym_names(sym)//' element') + 'Expected name of element') return endif elseif(check_name_no_repeat(parser,name,base+1)) then - call push_sym(parser,name) + call push_sym(parser,merge(-name,name,hasvar)) else call parse_error(parser,& - 'Expected name of '//sym_names(sym)//' element') + 'Expected name of element') return endif n=n+1 @@ -5477,7 +5683,7 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) call scan(parser) enddo - ! Structure definition record is: list{type},tag,typname,nargs,params,keys + ! Rec definition record is: list{type},tag,typname,nargs,params,keys call make_node(parser,sym_list,parser%vtop-vbase) call name_vector(parser,base) !if(hasuse) parser%vstack(parser%vtop)%offset=-parser%vstack(parser%vtop)%offset @@ -5485,14 +5691,14 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) call push_num_val(parser,nargs) call push_val(parser,params) call push_null_val(parser) - if(hasuse) flags=ior(flags,pm_type_has_embedded) + ! if(hasuse) flags=ior(flags,pm_type_has_embedded) call push_num_val(parser,flags) call make_node(parser,sym,7) if(expect(parser,sym_close_brace)) return iserr=.false. contains include 'fisnull.inc' - end function structrec + end function rec !====================================================== ! Parameter declarations @@ -5836,6 +6042,16 @@ subroutine drop_val(parser) parser%vtop=parser%vtop-1 end subroutine drop_val + !====================================================== + ! Replace second-to-top value on stack with top value + ! decreasing stack ptr by 1 + !====================================================== + subroutine push_down_val(parser) + type(parse_state),intent(inout):: parser + parser%vtop=parser%vtop-1 + parser%vstack(parser%vtop)=parser%vstack(parser%vtop+1) + end subroutine push_down_val + !====================================================== ! Top of value stack !====================================================== diff --git a/src/symbol.f90 b/src/symbol.f90 index 0ec6c95..b9b473f 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -67,32 +67,34 @@ module pm_symbol integer,parameter:: sym_dcolon = 23 integer,parameter:: sym_assign = 24 integer,parameter:: sym_cond = 25 - integer,parameter:: sym_string = 26 - integer,parameter:: sym_number = 27 + integer,parameter:: sym_move = 26 + integer,parameter:: sym_move_all = 27 + integer,parameter:: sym_swap = 28 + integer,parameter:: sym_string = 29 + integer,parameter:: sym_number = 30 ! Operators integer,parameter:: sym1 = sym_number integer,parameter:: sym_open = sym1 + 1 integer,parameter:: sym_close = sym1 + 2 - integer,parameter:: sym_open_smiley = sym1 + 3 - integer,parameter:: sym_close_smiley = sym1 + 4 - integer,parameter:: sym_le = sym1 + 5 - integer,parameter:: sym_lt = sym1 + 6 - integer,parameter:: sym_ustar = sym1 + 7 - integer,parameter:: sym_uhash = sym1 + 8 + integer,parameter:: sym_le = sym1 + 3 + integer,parameter:: sym_lt = sym1 + 4 + integer,parameter:: sym_ustar = sym1 + 5 + integer,parameter:: sym_uhash = sym1 + 6 integer,parameter:: sym2 = sym_uhash - - integer,parameter:: sym_concat = sym2 + 1 - integer,parameter:: first_operator = sym_concat - integer,parameter:: sym_eq = sym2 + 2 - integer,parameter:: sym_ne = sym2 + 3 - integer,parameter:: sym_ge = sym2 + 4 - integer,parameter:: sym_gt = sym2 + 5 - integer,parameter:: sym_plus = sym2 + 6 - integer,parameter:: sym_minus = sym2 + 7 - integer,parameter:: sym_mult = sym2 + 8 - integer,parameter:: sym_divide = sym2 + 9 + + integer,parameter:: sym_plus = sym2 + 1 + integer,parameter:: first_operator=sym_plus + integer,parameter:: sym_minus = sym2 + 2 + integer,parameter:: sym_mult = sym2 + 3 + integer,parameter:: sym_divide = sym2 + 4 + integer,parameter:: sym_concat = sym2 + 5 + integer,parameter:: first_non_idx_operator = sym_concat + integer,parameter:: sym_eq = sym2 + 6 + integer,parameter:: sym_ne = sym2 + 7 + integer,parameter:: sym_ge = sym2 + 8 + integer,parameter:: sym_gt = sym2 + 9 integer,parameter:: sym_pow = sym2 + 10 integer,parameter:: sym_dotdot = sym2 + 11 integer,parameter:: sym_bar = sym2 + 12 @@ -139,15 +141,21 @@ module pm_symbol integer,parameter:: last_word = last_expr ! Modes - integer,parameter:: sym_private = last_word + 1 + integer,parameter:: sym_private = last_word + 1 integer,parameter:: first_mode = sym_private - integer,parameter:: sym_chan = last_word + 2 - integer,parameter:: sym_local = last_word + 3 - integer,parameter:: sym_joint = last_word + 4 - integer,parameter:: sym_invar = last_word + 5 - integer,parameter:: sym_shared = last_word + 6 - integer,parameter:: last_mode = sym_shared - integer,parameter:: last_key = sym_shared + integer,parameter:: sym_joint = last_word + 2 + integer,parameter:: sym_uniform = last_word + 3 + integer,parameter:: sym_indep = last_word + 4 + + integer,parameter:: sym_chan = last_word + 5 + integer,parameter:: sym_nhd = last_word + 6 + integer,parameter:: sym_indexed = last_word + 7 + integer,parameter:: sym_local = last_word + 8 + + integer,parameter:: sym_invar = last_word + 9 + integer,parameter:: sym_shared = last_word + 10 + integer,parameter:: last_mode = sym_shared + integer,parameter:: last_key = sym_shared ! Declaration keywords integer,parameter:: sym_package = last_key +1 @@ -187,8 +195,8 @@ module pm_symbol integer,parameter:: sym_const = last_decl + 23 integer,parameter:: sym_each = last_decl + 24 integer,parameter:: sym_where = last_decl + 25 - integer,parameter:: sym_with = last_decl + 26 - integer,parameter:: sym_conc = last_decl + 27 + integer,parameter:: sym_distinct = last_decl + 26 + integer,parameter:: sym_forall = last_decl + 27 integer,parameter:: sym_interface = last_decl + 28 integer,parameter:: sym_if_invar = last_decl + 29 integer,parameter:: sym_while_invar = last_decl + 30 @@ -198,7 +206,9 @@ module pm_symbol integer,parameter:: sym_proceed= last_decl + 34 integer,parameter:: sym_after= last_decl + 35 integer,parameter:: sym_any_invar= last_decl + 36 - integer,parameter:: last_resv = sym_any_invar + integer,parameter:: sym_all = last_decl + 37 + integer,parameter:: sym_sync_while = last_decl + 38 + integer,parameter:: last_resv = sym_sync_while ! Names used by internal system integer,parameter:: sym_pm_send = last_resv + 1 @@ -221,10 +231,22 @@ module pm_symbol integer,parameter:: sym_pm_do_at = last_resv + 17 integer,parameter:: sym_pm_do = last_resv + 18 integer,parameter:: sym_pm_intrinsic = last_resv + 19 - integer,parameter:: sym_pm_if_compiling = last_resv + 20 - integer,parameter:: sym_pm_else = last_resv + 21 - integer,parameter:: sym_pm_endif = last_resv + 22 - integer,parameter:: last_stmt = sym_pm_endif + integer,parameter:: sym_pm_each_index = last_resv + 20 + integer,parameter:: sym_pm_if_compiling = last_resv + 21 + integer,parameter:: sym_pm_else = last_resv + 22 + integer,parameter:: sym_pm_endif = last_resv + 23 + integer,parameter:: sym_pm_yield = last_resv + 24 + integer,parameter:: sym_pm_set_dotdotdot = last_resv + 25 + integer,parameter:: sym_pm_for = last_resv + 26 + integer,parameter:: sym_pm_foreach = last_resv + 27 + integer,parameter:: sym_pm_over = last_resv + 28 + integer,parameter:: sym_pm_context = last_resv + 29 + integer,parameter:: sym_pm_shared = last_resv + 30 + integer,parameter:: sym_pm_shared_always = last_resv + 31 + integer,parameter:: sym_pm_chan = last_resv + 32 + integer,parameter:: sym_pm_chan_always = last_resv + 33 + integer,parameter:: sym_pm_list = last_resv + 34 + integer,parameter:: last_stmt = sym_pm_list integer,parameter:: num_sym = last_stmt ! Non-reserved words that the compiler needs to know about @@ -317,9 +339,10 @@ module pm_symbol integer,parameter:: sym_case_range = node0 + 47 integer,parameter:: sym_dot_call = node0 + 48 integer,parameter:: sym_key = node0 + 49 + integer,parameter:: sym_reference = node0 + 50 ! Misc. other symbols that need to be referenced by the compiler - integer,parameter:: hook = node0 + 50 + integer,parameter:: hook = node0 + 51 integer,parameter:: sym_pval_as = hook integer,parameter:: sym_pm_system = hook+1 integer,parameter:: sym_get_element = hook+2 @@ -330,7 +353,7 @@ module pm_symbol integer,parameter:: sym_import_shared = hook+7 integer,parameter:: sym_partition = hook+8 integer,parameter:: sym_check_conform = hook+9 - integer,parameter:: sym_dup = hook + 10 + integer,parameter:: sym_dupz = hook + 10 integer,parameter:: sym_assemble = hook + 11 integer,parameter:: sym_node_grid = hook + 12 integer,parameter:: sym_this_node = hook + 13 @@ -354,7 +377,34 @@ module pm_symbol integer,parameter:: sym_block_ins_a=hook + 31 integer,parameter:: sym_block_proc_a=hook + 32 integer,parameter:: sym_elem_at_index=hook + 33 - integer,parameter:: hook1 = hook + 33 + integer,parameter:: sym_amp_iter_args=hook + 34 + integer,parameter:: sym_star_iter_args=hook + 35 + integer,parameter:: sym_iter_args=hook + 36 + integer,parameter:: sym_pm_foreach_stmt=hook + 37 + integer,parameter:: sym_pm_foreach_invar_stmt=hook + 38 + integer,parameter:: sym_pm_for_stmt = hook + 39 + integer,parameter:: sym_pm_forall_stmt = hook + 40 + integer,parameter:: sym_pm_over_stmt = hook + 41 + integer,parameter:: sym_lhs_and_val = hook + 42 + integer,parameter:: sym_rhs_and_val = hook + 43 + integer,parameter:: sym_make_var= hook + 44 + integer,parameter:: sym_make_chan_var = hook + 45 + integer,parameter:: sym_make_nhd_var = hook + 46 + integer,parameter:: sym_make_lcl_var = hook + 47 + integer,parameter:: sym_make_invar_var = hook + 48 + integer,parameter:: sym_make_shared_var = hook + 49 + integer,parameter:: sym_make_const = hook + 50 + integer,parameter:: sym_chan_stmt = hook + 51 + integer,parameter:: sym_invar_stmt = hook + 52 + integer,parameter:: sym_shared_stmt = hook + 53 + integer,parameter:: sym_dechan = hook + 54 + integer,parameter:: sym_check_iter = hook + 55 + integer,parameter:: sym_check_iter_amp = hook + 56 + integer,parameter:: sym_check_iter_star = hook + 57 + integer,parameter:: sym_all_stmt = hook + 58 + integer,parameter:: sym_lhs_and_val_sync = hook + 59 + integer,parameter:: sym_iter_ref = hook + 60 + integer,parameter:: hook1 = hook + 60 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -363,8 +413,8 @@ module pm_symbol integer,parameter:: sym_d5= hook1 + 5 integer,parameter:: sym_d6= hook1 + 6 integer,parameter:: sym_d7= hook1 + 7 - integer,parameter:: sym_copy_out = hook1 + 8 - integer,parameter:: sym_copy_back = hook1 + 9 + integer,parameter:: sym_copy_in = hook1 + 8 + integer,parameter:: sym_copy_out = hook1 + 9 integer,parameter:: sym_assignment = hook1 + 10 integer,parameter:: sym_aliased_assign = hook1 + 11 integer,parameter:: sym_first = hook1 + 12 @@ -400,16 +450,15 @@ module pm_symbol integer,parameter:: sym_do_dim = hook3 + 1 integer,parameter:: sym_shape = hook3 + 2 integer,parameter:: sym_poly= hook3 + 3 - integer,parameter:: sym_pm_over = hook3 + 4 - integer,parameter:: sym_next_enum = hook3 + 5 - integer,parameter:: sym_make_distr = hook3 + 6 - integer,parameter:: sym_check_import = hook3 + 7 - integer,parameter:: sym_for_get_element = hook3 + 8 - integer,parameter:: sym_for_set_element = hook3 + 9 - integer,parameter:: sym_get_distr = hook3 + 10 - integer,parameter:: sym_get_darray = hook3 + 11 - integer,parameter:: sym_make_local = hook3 + 12 - integer,parameter:: hook4 = hook3 + 12 + integer,parameter:: sym_next_enum = hook3 + 4 + integer,parameter:: sym_make_distr = hook3 + 5 + integer,parameter:: sym_check_import = hook3 + 6 + integer,parameter:: sym_for_get_element = hook3 + 7 + integer,parameter:: sym_for_set_element = hook3 + 8 + integer,parameter:: sym_get_distr = hook3 + 9 + integer,parameter:: sym_get_darray = hook3 + 10 + integer,parameter:: sym_make_local = hook3 + 11 + integer,parameter:: hook4 = hook3 + 11 integer,parameter:: sym_make_ldist = hook4 + 1 integer,parameter:: sym_make_global = hook4 + 2 @@ -430,7 +479,7 @@ module pm_symbol integer,parameter:: sym_map_varray= hook4 + 17 integer,parameter:: sym_get_val_ref = hook4 + 18 integer,parameter:: sym_local_distr = hook4 + 19 - integer,parameter:: sym_pm_chan = hook4 + 20 + integer,parameter:: sym_make_chan = hook4 + 20 integer,parameter:: sym_get_chan = hook4 + 21 integer,parameter:: sym_pm_local = hook4 + 22 integer,parameter:: sym_casts_to = hook4 + 23 @@ -488,7 +537,7 @@ module pm_symbol !============================================== - character(len=20),dimension(0:num_syshook)::sym_names + character(len=22),dimension(0:num_syshook)::sym_names data sym_names(0) /''/ data sym_names(sym_at) /'@'/ data sym_names(sym_dollar) /'$'/ @@ -515,6 +564,9 @@ module pm_symbol data sym_names(sym_dcolon) /'::'/ data sym_names(sym_assign) /'='/ data sym_names(sym_cond) /'=>'/ + data sym_names(sym_move) /'<--'/ + data sym_names(sym_move_all) /'<=='/ + data sym_names(sym_swap) /'<->'/ data sym_names(sym_string) /''/ data sym_names(sym_number) /''/ @@ -522,8 +574,6 @@ module pm_symbol ! Operators data sym_names(sym_open) /'('/ data sym_names(sym_close) /')'/ - data sym_names(sym_open_smiley) /'(:'/ - data sym_names(sym_close_smiley) /':)'/ data sym_names(sym_le) /'<='/ data sym_names(sym_lt) /'<'/ data sym_names(sym_ustar) /'unary *'/ @@ -576,9 +626,13 @@ module pm_symbol data sym_names(sym_when) /'when'/ data sym_names(sym_private) /'priv'/ + data sym_names(sym_joint) /'jnt'/ + data sym_names(sym_uniform) /'unif'/ + data sym_names(sym_indep) /'indep'/ + data sym_names(sym_indexed) /'idx'/ data sym_names(sym_chan) /'chan'/ + data sym_names(sym_nhd) /'nhd'/ data sym_names(sym_local) /'lcl'/ - data sym_names(sym_joint) /'jnt'/ data sym_names(sym_invar) /'invar'/ data sym_names(sym_shared) /'shrd'/ @@ -616,17 +670,19 @@ module pm_symbol data sym_names(sym_const) /'const'/ data sym_names(sym_each) /'foreach'/ data sym_names(sym_where) /'where'/ - data sym_names(sym_with) /'with'/ - data sym_names(sym_conc) /'forall'/ + data sym_names(sym_distinct) /'distinct'/ + data sym_names(sym_forall) /'forall'/ data sym_names(sym_interface) /'interface'/ - data sym_names(sym_switch_invar) /'iswitch'/ - data sym_names(sym_if_invar) /''/ - data sym_names(sym_while_invar) /''/ - data sym_names(sym_until_invar) /''/ - data sym_names(sym_foreach_invar) /''/ + data sym_names(sym_switch_invar) /'switch invar'/ + data sym_names(sym_if_invar) /'if invar'/ + data sym_names(sym_while_invar) /'while invar'/ + data sym_names(sym_until_invar) /'until invar'/ + data sym_names(sym_foreach_invar) /'foreach invar'/ data sym_names(sym_proceed) /'proceed'/ data sym_names(sym_after) /'after'/ - data sym_names(sym_any_invar) /''/ + data sym_names(sym_any_invar) /'any invar'/ + data sym_names(sym_all) /'all'/ + data sym_names(sym_sync_while) /'sync while'/ data sym_names(sym_pm_send) /'PM__send'/ data sym_names(sym_pm_recv) /'PM__recv'/ @@ -647,10 +703,22 @@ module pm_symbol data sym_names(sym_pm_do_at) /'PM__do_at'/ data sym_names(sym_pm_do) /'PM__do'/ data sym_names(sym_pm_intrinsic) /'PM__intrinsic'/ + data sym_names(sym_pm_each_index) /'PM__each_index'/ data sym_names(sym_pm_if_compiling) /'PM__if_compiling'/ data sym_names(sym_pm_else) /'PM__else'/ data sym_names(sym_pm_endif) /'PM__endif'/ - + data sym_names(sym_pm_yield) /'PM__yield'/ + data sym_names(sym_pm_set_dotdotdot) /'PM__set_dotdotdot'/ + data sym_names(sym_pm_for) /'PM__for'/ + data sym_names(sym_pm_foreach) /'PM__foreach'/ + data sym_names(sym_pm_over) /'PM__over'/ + data sym_names(sym_pm_context) /'PM__context'/ + data sym_names(sym_pm_shared) /'PM__shrd'/ + data sym_names(sym_pm_shared_always) /'PM__shrd_always'/ + data sym_names(sym_pm_chan) /'PM__chan'/ + data sym_names(sym_pm_chan_always) /'PM__chan_always'/ + data sym_names(sym_pm_list) /'PM__list'/ + !=============================================================== data sym_names(sym_array) /'PM__array'/ @@ -673,7 +741,7 @@ module pm_symbol data sym_names(sym_ignore_rules) /'PM__ignore'/ data sym_names(sym_keep_literals) /'keep_literals'/ - data sym_names(sym_filesystem) /'filesystem'/ + data sym_names(sym_filesystem) /'IO'/ data sym_names(sym_proc_is_generator) /'is_generator'/ data sym_names(sym_proc_is_impure) /'is_impure'/ @@ -737,6 +805,7 @@ module pm_symbol data sym_names(sym_case_range) /'PM__caserange'/ data sym_names(sym_dot_call) /''/ data sym_names(sym_key) /''/ + data sym_names(sym_reference) /''/ ! Misc. symbols referenced by compiler @@ -749,7 +818,7 @@ module pm_symbol data sym_names(sym_import_shared) /'PM__importshrd'/ data sym_names(sym_partition) /'PM__partition'/ data sym_names(sym_check_conform) /'check_conform'/ - data sym_names(sym_dup) /'PM__dup'/ + data sym_names(sym_dupz) /'PM__dup'/ data sym_names(sym_assemble) /'PM__assemble'/ data sym_names(sym_node_grid) /'node_grid'/ data sym_names(sym_this_node) /'this_node'/ @@ -773,7 +842,36 @@ module pm_symbol data sym_names(sym_block_ins_a) /'PM__ins_a'/ data sym_names(sym_block_proc_a) /'PM__block_proc_a'/ data sym_names(sym_elem_at_index) /'element_at_index'/ + data sym_names(sym_amp_iter_args) /'PM__amp_iter_args'/ + data sym_names(sym_star_iter_args) /'PM__star_iter_args'/ + data sym_names(sym_iter_args) /'PM__iter_args'/ + data sym_names(sym_pm_foreach_stmt) /'PM__foreach_stmt'/ + data sym_names(sym_pm_foreach_invar_stmt) /'PM__foreach_invar_stmt'/ + data sym_names(sym_pm_for_stmt) /'PM__for_stmt'/ + data sym_names(sym_pm_forall_stmt) /'PM__forall_stmt'/ + data sym_names(sym_pm_over_stmt) /'PM__over_stmt'/ + data sym_names(sym_lhs_and_val) /'PM__lhs_and_val'/ + data sym_names(sym_rhs_and_val) /'PM__rhs_and_val'/ + data sym_names(sym_make_var) /'PM__make_var'/ + data sym_names(sym_make_chan_var) /'PM__make_chan_var'/ + data sym_names(sym_make_nhd_var) /'PM__make_nhd_var'/ + data sym_names(sym_make_lcl_var) /'PM__make_lcl_var'/ + data sym_names(sym_make_invar_var) /'PM__make_invar_var'/ + data sym_names(sym_make_shared_var) /'PM__make_shrd_var'/ + data sym_names(sym_make_const) /'PM__make_const'/ + + data sym_names(sym_chan_stmt) /'PM__chan_stmt'/ + data sym_names(sym_invar_stmt) /'PM__invar_stmt'/ + data sym_names(sym_shared_stmt) /'PM__shrd_stmt'/ + data sym_names(sym_dechan) /'PM__dechan'/ + data sym_names(sym_check_iter) /'PM__check_iter'/ + data sym_names(sym_check_iter_amp) /'PM__check_iter_amp'/ + data sym_names(sym_check_iter_star) /'PM__check_iter_star'/ + + data sym_names(sym_all_stmt) /'PM__all_stmt'/ + data sym_names(sym_lhs_and_val_sync) /'PM__lhs_and_val_sync'/ + data sym_names(sym_iter_ref) /'PM__iter_ref'/ data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ @@ -783,8 +881,8 @@ module pm_symbol data sym_names(sym_d6) /'PM__d6'/ data sym_names(sym_d7) /'PM__d7'/ + data sym_names(sym_copy_in) /'PM__copy_in'/ data sym_names(sym_copy_out) /'PM__copy_out'/ - data sym_names(sym_copy_back) /'PM__copy_back'/ data sym_names(sym_assignment) /'PM__assign'/ data sym_names(sym_aliased_assign) /'PM__aliased_assign'/ data sym_names(sym_first) /'PM__first'/ @@ -819,7 +917,6 @@ module pm_symbol data sym_names(sym_do_dim) /'PM__do_dim'/ data sym_names(sym_shape) /'shape'/ data sym_names(sym_poly) /'poly'/ - data sym_names(sym_pm_over) /'PM__over'/ data sym_names(sym_next_enum) /'next_enum'/ data sym_names(sym_make_distr) /'PM__distr'/ data sym_names(sym_check_import) /'PM__checkimp'/ @@ -848,7 +945,7 @@ module pm_symbol data sym_names(sym_map_varray) /'PM__mapvarray'/ data sym_names(sym_get_val_ref) /'PM__valref'/ data sym_names(sym_local_distr) /'local_distr'/ - data sym_names(sym_pm_chan) /'PM__chan'/ + data sym_names(sym_make_chan) /'PM__make_chan'/ data sym_names(sym_get_chan) /'PM__getchan'/ data sym_names(sym_pm_local) /'PM__local'/ data sym_names(sym_casts_to) /'casts_to'/ diff --git a/src/types.f90 b/src/types.f90 index 2a661d2..bd39206 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2024 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -42,7 +42,7 @@ module pm_types integer,parameter:: pm_type_has_poly=256 integer,parameter:: pm_type_has_generic=512 integer,parameter:: pm_type_has_vect=1024 - integer,parameter:: pm_type_has_embedded=2048 + integer,parameter:: pm_type_has_fix_or_literal=2048 integer,parameter:: pm_type_has_params=4096 integer,parameter:: pm_type_is_soa=8192 integer,parameter:: pm_type_is_aos=16384 @@ -54,11 +54,12 @@ module pm_types integer,parameter:: pm_type_is_list=32768 ! Bitwise-or of flags which are not taints (only one so far) - integer,parameter:: pm_type_flags_untainting = pm_type_has_embedded + integer,parameter:: pm_type_flags_untainting = pm_type_is_list + pm_type_is_when + pm_type_is_yield + & + pm_type_is_soa + pm_type_is_aos + pm_type_is_seq ! Type kind + default flags integer,parameter:: pm_type_new_user=1 - integer,parameter:: pm_type_new_struct=2 + integer,parameter:: pm_type_new_error=2 integer,parameter:: pm_type_new_rec=3 integer,parameter:: pm_type_new_array=4+pm_type_has_array integer,parameter:: pm_type_new_tuple=5 @@ -69,14 +70,14 @@ module pm_types integer,parameter:: pm_type_new_any=10+pm_type_has_generic integer,parameter:: pm_type_new_poly=11+pm_type_has_poly+& pm_type_has_storage - integer,parameter:: pm_type_new_value=12 + integer,parameter:: pm_type_new_fix_value=12 integer,parameter:: pm_type_new_contains=13 - integer,parameter:: pm_type_new_fix=14 !+pm_type_has_storage + integer,parameter:: pm_type_new_fix=14 integer,parameter:: pm_type_new_dref=15 integer,parameter:: pm_type_new_par_kind=16 integer,parameter:: pm_type_new_proc_sig=17 integer,parameter:: pm_type_new_undef_result=18 - integer,parameter:: pm_type_new_literal=19 + integer,parameter:: pm_type_new_literal_value=19 integer,parameter:: pm_type_new_except=20 integer,parameter:: pm_type_new_param=21+pm_type_has_params @@ -93,7 +94,7 @@ module pm_types ! Type kinds integer,parameter:: pm_type_is_basic=0 integer,parameter:: pm_type_is_user=1 - integer,parameter:: pm_type_is_struct=2 + integer,parameter:: pm_type_is_error=2 integer,parameter:: pm_type_is_rec=3 integer,parameter:: pm_type_is_array=4 integer,parameter:: pm_type_is_tuple=5 @@ -103,14 +104,14 @@ module pm_types integer,parameter:: pm_type_is_all=9 integer,parameter:: pm_type_is_any=10 integer,parameter:: pm_type_is_poly=11 - integer,parameter:: pm_type_is_value=12 + integer,parameter:: pm_type_is_fix_value=12 integer,parameter:: pm_type_is_contains=13 integer,parameter:: pm_type_is_fix=14 integer,parameter:: pm_type_is_dref=15 integer,parameter:: pm_type_is_par_kind=16 integer,parameter:: pm_type_is_proc_sig=17 integer,parameter:: pm_type_is_undef_result=18 - integer,parameter:: pm_type_is_literal=19 + integer,parameter:: pm_type_is_literal_value=19 integer,parameter:: pm_type_is_except=20 integer,parameter:: pm_type_is_param=21 ! @@ -121,7 +122,7 @@ module pm_types integer,parameter:: pm_type_is_category=27 integer,parameter:: pm_type_is_bottom=28 integer,parameter:: pm_type_is_includes=29 - integer,parameter:: pm_type_is_unfixed=30 + integer,parameter:: pm_type_is_literal=30 integer,parameter:: pm_type_is_uninitialised=31 integer,parameter:: pm_type_kind_mask=31 @@ -142,12 +143,6 @@ module pm_types integer,parameter:: pm_elem_not_found=1 integer,parameter:: pm_elem_clash=2 - ! Information on location and kind of non-match/type error - type pm_type_einfo - integer:: kind - integer:: index - integer:: name,vname,typ1,typ2,vtyp1,vtyp2 - end type pm_type_einfo ! Error codes from type testing integer,parameter:: pm_type_err_none=0 @@ -167,23 +162,21 @@ module pm_types integer(pm_p),public,parameter:: pm_prc_type = pm_last_lib_type+1 integer(pm_p),public,parameter:: pm_string_type=pm_last_lib_type+2 integer(pm_p),public,parameter:: pm_poly_type=pm_last_lib_type+3 - integer(pm_p),public,parameter:: pm_struct_type=pm_last_lib_type+4 - integer(pm_p),public,parameter:: pm_rec_type=pm_last_lib_type+5 - integer(pm_p),public,parameter:: pm_polyref_type=pm_last_lib_type+6 - integer(pm_p),public,parameter:: pm_array_type=pm_last_lib_type+7 - integer(pm_p),public,parameter:: pm_const_array_type=pm_last_lib_type+8 - integer(pm_p),public,parameter:: pm_dref_type=pm_last_lib_type+9 - integer(pm_p),public,parameter:: pm_dref_shared_type=pm_last_lib_type+10 - integer(pm_p),public,parameter:: pm_elemref_type=pm_last_lib_type+11 + integer(pm_p),public,parameter:: pm_rec_type=pm_last_lib_type+4 + integer(pm_p),public,parameter:: pm_polyref_type=pm_last_lib_type+5 + integer(pm_p),public,parameter:: pm_array_type=pm_last_lib_type+6 + integer(pm_p),public,parameter:: pm_const_array_type=pm_last_lib_type+7 + integer(pm_p),public,parameter:: pm_dref_type=pm_last_lib_type+8 + integer(pm_p),public,parameter:: pm_dref_shared_type=pm_last_lib_type+9 + integer(pm_p),public,parameter:: pm_elemref_type=pm_last_lib_type+10 integer(pm_p),public,parameter:: pm_last_sys_type=pm_elemref_type ! Categorical types - integer,public,parameter:: pm_a_struct_type = pm_last_sys_type + 1 - integer,public,parameter:: pm_a_rec_type = pm_last_sys_type + 2 - integer,public,parameter:: pm_a_unique_type = pm_last_sys_type + 3 - integer,public,parameter:: pm_a_fix_type = pm_last_sys_type + 4 - integer,public,parameter:: pm_a_literal_type = pm_last_sys_type + 5 - integer,public,parameter:: pm_a_basic_type = pm_last_sys_type + 6 + integer,public,parameter:: pm_a_rec_type = pm_last_sys_type + 1 + integer,public,parameter:: pm_a_unique_type = pm_last_sys_type + 2 + integer,public,parameter:: pm_a_fix_type = pm_last_sys_type + 3 + integer,public,parameter:: pm_a_literal_type = pm_last_sys_type + 4 + integer,public,parameter:: pm_a_basic_type = pm_last_sys_type + 5 integer,public,parameter:: pm_last_category_type = pm_a_basic_type ! Literal types @@ -227,9 +220,9 @@ subroutine pm_init_types(context) ' ',' ',' ','bool ',& ' ',' ',' ',' ',& ' ',' ',' ',' ',& - 'prc_info ','string ',' ',' ',& + 'prc_info ','string ',' ',& ' ',' ',' ',' ',& - ' ',' ',' ','a_struct ',& + ' ',' ',' ',& 'a_rec ','a_unique ','a_fix ','a_literal ',& 'a_basic '/) @@ -461,14 +454,14 @@ function pm_type_combine(context,a,b) result(tno) integer,intent(in):: a,b integer:: tno integer,dimension(4):: args - type(pm_type_einfo):: einfo + if(a==b) then tno=a return - elseif(pm_type_includes(context,a,b,pm_type_incl_type,einfo)) then + elseif(pm_type_includes(context,a,b,pm_type_incl_type)) then tno=a return - elseif(pm_type_includes(context,b,a,pm_type_incl_type,einfo)) then + elseif(pm_type_includes(context,b,a,pm_type_incl_type)) then tno=b return endif @@ -523,16 +516,32 @@ function pm_new_includes_type(context,etyp,mtyp) result(tno) tno=pm_new_basic_type(context,args) end function pm_new_includes_type + !============================================== + ! Create new compile time name value type + !============================================== + function pm_new_name_type(context,name) result(tno) + type(pm_context),pointer:: context + integer,intent(in):: name + integer:: tno + integer,dimension(2):: args + args(1)=pm_type_new_single_name + if(pm_name_stem(context,name)==sym_distr_tag) then + args(1)=ior(args(1),pm_type_has_distributed) + endif + args(2)=name + tno=pm_new_type(context,args) + end function pm_new_name_type + !========================================== ! Create new compile time value type !========================================== - function pm_new_fix_type(context,val,vindex) result(tno) + function pm_new_fix_value_type(context,val,vindex) result(tno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val integer,intent(in),optional:: vindex integer:: tno integer,dimension(3):: args - args(1)=pm_type_new_value + args(1)=pm_type_new_fix_value if(present(vindex)) then args(2)=vindex else @@ -543,40 +552,52 @@ function pm_new_fix_type(context,val,vindex) result(tno) tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' - end function pm_new_fix_type + end function pm_new_fix_value_type !========================================== ! Create new compile time value type !========================================== - function pm_new_literal_type(context,val) result(tno) + function pm_new_literal_value_type(context,val,vindex) result(tno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val + integer,intent(in),optional:: vindex integer:: tno integer,dimension(3):: args - args(1)=pm_type_new_literal - args(2)=pm_set_add(context,context%vcache,val) + args(1)=pm_type_new_literal_value + if(present(vindex)) then + args(2)=vindex + else + args(2)=pm_set_add(context,context%vcache,val) + endif args(3)=pm_fast_typeof(val) if(args(3)==pm_string) args(3)=pm_string_type tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' - end function pm_new_literal_type + end function pm_new_literal_value_type !============================================== - ! Create new compile time name value type + ! Create new pending error type !============================================== - function pm_new_name_type(context,name) result(tno) + function pm_new_error_type(context,val) result(tno) type(pm_context),pointer:: context - integer,intent(in):: name + type(pm_ptr),intent(in):: val integer:: tno integer,dimension(2):: args - args(1)=pm_type_new_single_name - if(pm_name_stem(context,name)==sym_distr_tag) then - args(1)=ior(args(1),pm_type_has_distributed) - endif - args(2)=name - tno=pm_new_type(context,args) - end function pm_new_name_type + args(1)=pm_type_new_error + args(2)=pm_set_add(context,context%vcache,val) + tno=pm_new_basic_type(context,args,val) + end function pm_new_error_type + + !============================================== + ! Create new pending error type from a string + !============================================== + function pm_error_type_from_string(context,str) result(tno) + type(pm_context),pointer:: context + character(len=*):: str + integer:: tno + tno=pm_new_error_type(context,pm_new_string(context,str)) + end function pm_error_type_from_string !============================================= ! Create new compile time proc value type @@ -752,9 +773,9 @@ function pm_type_elem_name(context,tno,n) result(name) tv=pm_type_vect(context,tno) if(pm_debug_checks) then kind=pm_tv_kind(tv) - if(kind/=pm_type_is_struct.and.kind/=pm_type_is_rec) then + if(kind/=pm_type_is_rec) then write(*,*) 'tno=',tno,'kind=',kind - call pm_panic('typ_elem_name not struct/rec') + call pm_panic('typ_elem_name not rec') endif endif name=pm_tv_name(tv) @@ -888,7 +909,7 @@ recursive function pm_type_strip_to_basic(context,typ) result(typ2) select case(kind) case(pm_type_is_all,pm_type_is_vect,& pm_type_is_param,& - pm_type_is_value,pm_type_is_literal) + pm_type_is_fix_value,pm_type_is_literal_value) typ2=pm_type_strip_to_basic(context,pm_tv_arg(tv,1)) case(pm_type_is_user) typ2=pm_user_type_body(context,typ) @@ -982,7 +1003,6 @@ function pm_type_replace_mode(context,typ1,mode) result(typ2) integer:: typ2 integer:: array(3),typ type(pm_ptr):: tv - if(typ1<=0) then typ2=typ1 return @@ -1146,24 +1166,22 @@ function pm_type_extract_params(context,templ,typ,params) result(ok) type(pm_context),pointer:: context integer,intent(in):: templ,typ integer,intent(inout),dimension(:):: params - type(pm_type_einfo):: einfo logical:: ok integer:: ubase integer,dimension(max_user_nesting):: user ubase=1 ok=pm_test_type_includes(context,templ,typ,& - pm_type_incl_val+pm_type_incl_extract,einfo,params,1,user,ubase) + pm_type_incl_val+pm_type_incl_extract,params,1,user,ubase) end function pm_type_extract_params !====================================== ! Does supertype include subtype? !====================================== function pm_type_includes(context,supertype,subtype,& - mode,einfo) result(ok) + mode) result(ok) type(pm_context),pointer:: context integer,intent(in):: supertype,subtype integer,intent(in):: mode - type(pm_type_einfo),intent(out):: einfo logical:: ok integer:: ubase integer,dimension(max_user_nesting):: user,params @@ -1181,11 +1199,8 @@ function pm_type_includes(context,supertype,subtype,& endif endif - einfo%kind=pm_type_err_none - einfo%typ1=supertype - einfo%typ2=subtype ok=pm_test_type_includes(context,supertype,subtype,& - mode,einfo,params,1,user,ubase) + mode,params,1,user,ubase) if(pm_type_extra_debug) then write(*,*) 'CHECKED ',ok,trim(pm_type_as_string(context,supertype)),'>>',& trim(pm_type_as_string(context,subtype)) @@ -1201,12 +1216,11 @@ end function pm_type_includes ! prevent runaway recursion !====================================================== recursive function pm_test_type_includes(context,supertype,subtype,& - mode,einfo,params,base,user,ubase)& + mode,params,base,user,ubase)& result(ok) type(pm_context),pointer:: context integer,intent(in):: supertype,subtype integer,intent(in):: mode - type(pm_type_einfo),intent(out):: einfo integer,dimension(:),intent(inout):: params integer,intent(in):: base integer,dimension(:),intent(inout):: user @@ -1239,11 +1253,11 @@ recursive function pm_test_type_includes(context,supertype,subtype,& if(tk==pm_type_is_user) then r=pm_dict_val(context,context%tcache,int(p,pm_ln)) ok=pm_test_type_includes(context,int(r%offset),q,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) elseif(tk==pm_type_is_any) then do i=1,pm_tv_numargs(t) if(pm_test_type_includes(context,pm_tv_arg(t,i),q,& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. return endif @@ -1270,19 +1284,19 @@ recursive function pm_test_type_includes(context,supertype,subtype,& if(tk==pm_type_is_includes) then if(uk==pm_type_is_includes) then ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) if(ok) then ok=ok.and.pm_test_type_includes(context,& pm_tv_arg(u,2),pm_tv_arg(t,2),& - pm_type_incl_equiv,einfo,params,base,user,ubase) + pm_type_incl_equiv,params,base,user,ubase) endif else ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) if(ok) then ok=ok.and.pm_test_type_includes(context,& q,pm_tv_arg(t,2),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) endif endif return @@ -1301,36 +1315,36 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=.true. return endif - case(pm_type_is_value) + case(pm_type_is_fix_value) select case(tk) case(pm_type_is_fix) - ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& params,base,user,ubase) return - case(pm_type_is_value) + case(pm_type_is_fix_value) ok=pm_tv_name(t)==pm_tv_name(u) return case(pm_type_is_basic) - ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,einfo,& + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,& params,base,user,ubase) return end select - case(pm_type_is_literal) - if(tk==pm_type_is_unfixed) then - ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + case(pm_type_is_literal_value) + if(tk==pm_type_is_literal) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& params,base,user,ubase) return - elseif(tk==pm_type_is_literal) then + elseif(tk==pm_type_is_literal_value) then ok=pm_tv_name(t)==pm_tv_name(u) return end if - case(pm_type_is_fix,pm_type_is_unfixed) + case(pm_type_is_fix,pm_type_is_literal) if(tk==uk.or.tk==pm_type_is_fix) then - ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& params,base,user,ubase) return elseif(tk/=pm_type_is_user) then - ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,einfo,& + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,& params,base,user,ubase) return endif @@ -1349,13 +1363,13 @@ recursive function pm_test_type_includes(context,supertype,subtype,& user(ubase+2)=q r=pm_dict_val(context,context%tcache,int(q,pm_ln)) ok=pm_test_type_includes(context,p,int(r%offset),& - mode,einfo,params,base,user,ubase+2) + mode,params,base,user,ubase+2) return endif case(pm_type_is_any) do i=1,pm_tv_numargs(u) if(.not.pm_test_type_includes(context,p,pm_tv_arg(u,i),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase)) then + ior(mode,pm_type_incl_nomatch),params,base,user,ubase)) then ok=.false. return endif @@ -1365,7 +1379,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_all) do i=1,pm_tv_numargs(u) if(pm_test_type_includes(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. return endif @@ -1375,18 +1389,18 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_except) if(tk==pm_type_is_except) then ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase).and.& + mode,params,base,user,ubase).and.& pm_test_type_includes(context,pm_tv_arg(u,2),pm_tv_arg(t,2),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) return else ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) return endif case(pm_type_is_includes) ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) return case(pm_type_is_undef_result) ok=.false. @@ -1399,12 +1413,12 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=pm_mode_includes(nt,nu) if(ok) then ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) endif else if(nt==nu) then ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) else ok=pm_mode_includes(nt,nu) endif @@ -1412,12 +1426,12 @@ recursive function pm_test_type_includes(context,supertype,subtype,& return else ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) return endif case(pm_type_is_param) ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) return case(pm_type_is_bottom) ok=.true. @@ -1450,13 +1464,13 @@ recursive function pm_test_type_includes(context,supertype,subtype,& endif do i=1,pm_tv_numargs(t) if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then + pm_tv_arg(u,i),mode,params,base,user,ubase)) then ok=.false. return endif enddo ok=.true. - case(pm_type_is_struct,pm_type_is_rec) + case(pm_type_is_rec) if(tk/=uk) then ok=.false. return @@ -1467,13 +1481,8 @@ recursive function pm_test_type_includes(context,supertype,subtype,& endif do i=1,pm_tv_numargs(t) if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then + pm_tv_arg(u,i),mode,params,base,user,ubase)) then ok=.false. - einfo%kind=ior(einfo%kind,pm_type_err_elem) - einfo%name=pm_tv_name(t) - einfo%index=i - einfo%typ1=pm_tv_arg(t,i) - einfo%typ2=pm_tv_arg(u,i) return endif enddo @@ -1486,9 +1495,9 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=.false. else ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase).and.& + mode,params,base,user,ubase).and.& pm_test_type_includes(context,pm_tv_arg(t,2),pm_tv_arg(u,2),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) endif endif case(pm_type_is_type,pm_type_is_poly) @@ -1496,7 +1505,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=.false. else ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) endif case(pm_type_is_tuple,pm_type_is_vtuple) if(uk/=pm_type_is_tuple.and.uk/=pm_type_is_vtuple) then @@ -1538,7 +1547,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& endif do i=j,min(nt,nu) if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then + pm_tv_arg(u,i),mode,params,base,user,ubase)) then ok=.false. return endif @@ -1546,7 +1555,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& if(nu>nt) then do i=nt+1,nu if(.not.pm_test_type_includes(context,pm_tv_arg(t,nt),& - pm_tv_arg(u,i),mode,einfo,params,base,& + pm_tv_arg(u,i),mode,params,base,& user,ubase)) then ok=.false. return @@ -1555,7 +1564,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& else do i=nu+1,nt if(.not.pm_test_type_includes(context,pm_tv_arg(t,nt),& - pm_tv_arg(u,i),mode,einfo,params,base,& + pm_tv_arg(u,i),mode,params,base,& user,ubase)) then ok=.false. return @@ -1574,7 +1583,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& do i=1,nt ok=pm_test_type_includes(context,& pm_tv_arg(t,i),pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) if(.not.ok) return enddo ok=.true. @@ -1597,16 +1606,16 @@ recursive function pm_test_type_includes(context,supertype,subtype,& user(ubase+2)=q r=pm_dict_val(context,context%tcache,int(p,pm_ln)) ok=pm_test_type_includes(context,int(r%offset),q,& - mode,einfo,params,base,user,ubase+2) + mode,params,base,user,ubase+2) else r=pm_dict_val(context,context%tcache,int(p,pm_ln)) ok=pm_test_type_includes(context,int(r%offset),q,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) endif case(pm_type_is_any) do i=1,pm_tv_numargs(t) if(pm_test_type_includes(context,pm_tv_arg(t,i),q,& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase)) then + ior(mode,pm_type_incl_nomatch),params,base,user,ubase)) then ok=.true. return endif @@ -1615,7 +1624,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_all) do i=1,pm_tv_numargs(t) if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),q,& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.false. return endif @@ -1638,7 +1647,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=pm_test_type_includes(context,& pm_tv_arg(t,1),pm_tv_arg(u,1),& pm_type_incl_type+pm_type_incl_nomatch,& - einfo,params,base,user,ubase) + params,base,user,ubase) endif case(pm_type_is_proc_sig) if(uk/=pm_type_is_proc_sig) then @@ -1652,72 +1661,53 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=pm_test_type_includes(context,& pm_tv_arg(u,1),pm_tv_arg(t,1),& pm_type_incl_type+pm_type_incl_nomatch,& - einfo,params,base,user,ubase).and.& + params,base,user,ubase).and.& pm_test_type_includes(context,& pm_tv_arg(t,2),pm_tv_arg(u,2),& pm_type_incl_type+pm_type_incl_nomatch,& - einfo,params,base,user,ubase) + params,base,user,ubase) case(pm_type_is_par_kind) ! Most cases catered for by uk switch - remaining case ok=iand(mode,pm_type_incl_val)/=0.and.& pm_mode_includes(pm_tv_name(t),sym_private).and.& pm_test_type_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) case(pm_type_is_undef_result) ok=.false. case(pm_type_is_contains) if(uk==pm_type_is_contains) then ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) else ok=pm_type_contains_elem(context,pm_tv_arg(t,1),q,& - ior(mode,pm_type_incl_nomatch),einfo,params,base,user,ubase) - endif - case(pm_type_is_has) - if(uk==pm_type_is_has) then - ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) - else - i=ubase+1 - r=pm_type_vect(context,pm_tv_arg(t,1)) - if(pm_tv_kind(r)==pm_type_is_proc.and.& - pm_tv_kind(u)==pm_type_is_proc) then - do i=1,pm_tv_numargs(u) - if(pm_proc_type_conforms(context,pm_tv_arg(t,1),& - pm_tv_arg(u,i))) then - ok=.true. - return - endif - enddo - endif - call pm_indirect_include(context,pm_tv_arg(t,1),q,user,& - size(user),i,einfo,j,s) - ok=s==pm_elem_found - if(ok) then - ! This test does parameter checking in correct context - ! (indirect_include checks in isolated context) - ok=pm_test_type_includes(context,& - pm_tv_arg(t,1),j,& - mode,einfo,params,base,user,ubase) - endif + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) endif - case(pm_type_is_value,pm_type_is_literal) + case(pm_type_is_fix_value,pm_type_is_literal_value) ok=.false. case(pm_type_is_fix) - ok=.false. - case(pm_type_is_unfixed) + if(pm_tv_name(t)>0) then + ! fix? + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + mode,params,base,user,ubase) + else + ok=.false. + endif + case(pm_type_is_literal) if(tk==uk) then ok=pm_tv_arg(t,1)==0.or.& pm_tv_arg(t,1)==pm_tv_arg(u,1) + elseif(pm_tv_name(t)>0) then + ! literal? + ok=pm_tv_arg(t,1)==q else ok=.false. endif case(pm_type_is_except) ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) if(ok) then ok=.not.pm_test_type_includes(context,pm_tv_arg(t,2),q,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) endif case(pm_type_is_params) nt=pm_tv_name(t) @@ -1726,10 +1716,10 @@ recursive function pm_test_type_includes(context,supertype,subtype,& endif params(base:base+nt)=-1 ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base+nt,user,ubase) + mode,params,base+nt,user,ubase) case(pm_type_is_param) ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) if(ok.and.iand(mode,pm_type_incl_extract)/=0) then if(iand(mode,pm_type_incl_nomatch)/=0) return nt=pm_tv_name(t) @@ -1742,19 +1732,17 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_vect,pm_type_is_uninitialised) ok=tk==uk if(ok) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) case(pm_type_is_bottom) ok=.false. case(pm_type_is_category) select case(p) - case(pm_a_struct_type) - ok=uk==pm_type_is_struct case(pm_a_rec_type) ok=uk==pm_type_is_rec case(pm_a_unique_type) ok=uk==pm_type_is_single_name case(pm_a_literal_type) - ok=uk==pm_type_is_unfixed + ok=uk==pm_type_is_literal case(pm_a_fix_type) ok=uk==pm_type_is_fix case(pm_a_basic_type) @@ -1822,11 +1810,10 @@ end function pm_type_is_recur ! array domain or values, applied recursively) of a given ! type? recursive function pm_type_contains_elem(context,p,q,& - mode,einfo,params,base,user,ubase) result(ok) + mode,params,base,user,ubase) result(ok) type(pm_context),pointer:: context integer,intent(in):: p,q integer,intent(in):: mode - type(pm_type_einfo),intent(out):: einfo integer,dimension(:),intent(inout):: params integer,intent(in):: base integer,dimension(:),intent(inout):: user @@ -1834,7 +1821,7 @@ recursive function pm_type_contains_elem(context,p,q,& type(pm_ptr):: u logical:: ok integer:: i,k,uk - if(pm_test_type_includes(context,p,q,mode,einfo,& + if(pm_test_type_includes(context,p,q,mode,& params,base,user,ubase)) then ok=.true. return @@ -1849,7 +1836,7 @@ recursive function pm_type_contains_elem(context,p,q,& case(pm_type_is_all) do i=1,pm_tv_numargs(u) if(pm_type_contains_elem(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. return endif @@ -1858,7 +1845,7 @@ recursive function pm_type_contains_elem(context,p,q,& case(pm_type_is_any) do i=1,pm_tv_numargs(u) if(.not.pm_type_contains_elem(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.false. return endif @@ -1866,28 +1853,27 @@ recursive function pm_type_contains_elem(context,p,q,& ok=.true. case(pm_type_is_except) ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) if(ok) then ok=.not.pm_type_includes(context,pm_tv_arg(u,2),& - p,pm_type_incl_type,einfo) + p,pm_type_incl_type) endif case(pm_type_is_array) if(pm_type_contains_elem(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. return elseif(pm_type_contains_elem(context,p,pm_tv_arg(u,2),& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. return else ok=.false. endif - case(pm_type_is_struct,pm_type_is_rec,& - pm_type_is_tuple,pm_type_is_vtuple) + case(pm_type_is_rec,pm_type_is_tuple,pm_type_is_vtuple) do i=1,pm_tv_numargs(u) if(pm_type_contains_elem(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. return endif @@ -1895,7 +1881,7 @@ recursive function pm_type_contains_elem(context,p,q,& ok=.false. case(pm_type_is_dref) ok=pm_type_contains_elem(context,p,pm_tv_arg(u,3),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) if(.not.ok) then i=pm_tv_arg(u,2) k=pm_type_kind(context,i) @@ -1906,14 +1892,14 @@ recursive function pm_type_contains_elem(context,p,q,& endif if(k==pm_type_is_dref) then ok=pm_type_contains_elem(context,p,i,& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) endif endif case(pm_type_is_par_kind,pm_type_is_vect,& pm_type_is_contains,pm_type_is_has,& pm_type_is_params,pm_type_is_param) ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + mode,params,base,user,ubase) case default ok=.false. end select @@ -1929,46 +1915,83 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c integer,intent(in):: partyp,argtyp logical,intent(in):: doliteral,doproc,dopoly integer:: ctyp - integer:: tk,ptyp + integer:: tk,ptyp,atyp,pmode,amode type(pm_ptr):: tv - type(pm_type_einfo):: einfo - integer:: arr(3) !!$ write(*,*) 'Convert',trim(pm_type_as_string(context,partyp)),& -!!$ '<-',trim(pm_type_as_string(context,argtyp)),doliteral +!!$ '<-',trim(pm_type_as_string(context,argtyp)),doliteral,doproc ctyp=-1 - ptyp=partyp if(partyp<0.or.argtyp<0) then return endif + ptyp=partyp + atyp=pm_type_strip_mode(context,argtyp,amode) tk=pm_type_kind(context,ptyp) + if(tk==pm_type_is_par_kind) then + if(.not.pm_mode_includes(pm_type_name(context,ptyp),amode)) return + ptyp=pm_type_arg(context,ptyp,1) + tk=pm_type_kind(context,ptyp) + endif do while(tk==pm_type_is_user) ptyp=pm_user_type_body(context,ptyp) tk=pm_type_kind(context,ptyp) enddo - if(doliteral.and.pm_type_kind(context,argtyp)==pm_type_is_literal) then - ctyp=pm_type_arg(context,argtyp,1) - if(tk==pm_type_is_fix) then - if(pm_type_includes(context,pm_type_arg(context,ptyp,1),ctyp,& - pm_type_incl_val,einfo)) then - ctyp=pm_new_fix_type(context,& - pm_type_val(context,argtyp),pm_type_name(context,argtyp)) - endif - elseif(tk==pm_type_is_value) then - if(pm_type_name(context,ptyp)==pm_type_name(context,argtyp)) then - ctyp=ptyp - endif - elseif(tk==pm_type_is_unfixed) then - ctyp=argtyp - endif + if(doliteral.and.pm_type_kind(context,atyp)==pm_type_is_literal_value) then + ctyp=pm_literal_type_convert(context,ptyp,atyp) endif - if(ctyp<0.and.doproc.and.tk==pm_type_is_proc) then - ctyp=pm_proc_type_convert(context,ptyp,argtyp) + if(ctyp<0.and.doproc.and.tk==pm_type_is_proc) then + ctyp=pm_proc_type_convert(context,ptyp,atyp) endif if(ctyp<0.and.dopoly.and.tk==pm_type_is_poly) then - ctyp=pm_poly_type_convert(context,ptyp,argtyp) + ctyp=pm_poly_type_convert(context,ptyp,atyp) endif + ctyp=pm_type_add_mode(context,ctyp,amode) end function pm_type_convert + + !================================================================ + ! Autoconversion of a literal type + !================================================================ + function pm_literal_type_convert(context,partyp,argtyp) result(ctyp) + type(pm_context),pointer:: context + integer,intent(in):: partyp,argtyp + integer:: ctyp + integer:: tk + ctyp=pm_type_arg(context,argtyp,1) + tk=pm_type_kind(context,partyp) + if(tk==pm_type_is_fix) then + if(pm_type_includes(context,pm_type_arg(context,partyp,1),ctyp,& + pm_type_incl_val)) then + ctyp=pm_new_fix_value_type(context,& + pm_type_val(context,argtyp),pm_type_name(context,argtyp)) + endif + elseif(tk==pm_type_is_fix_value) then + if(pm_type_name(context,partyp)==pm_type_name(context,argtyp)) then + ctyp=partyp + endif + elseif(tk==pm_type_is_literal) then + ctyp=argtyp + endif + end function pm_literal_type_convert + + !========================================================= + ! Convert a moded literal type to a moded non-literal type + !========================================================= + function pm_type_strip_literal(context,typ) result(ctyp) + type(pm_context),pointer:: context + integer,intent(in):: typ + integer:: ctyp + integer:: tno,tk,mode + type(pm_ptr):: tv + ctyp=typ + if(typ<=0) return + tno=pm_type_strip_mode(context,typ,mode) + tv=pm_type_vect(context,tno) + tk=pm_tv_kind(tv) + if(tk==pm_type_is_literal_value.or.tk==pm_type_is_fix_value) then + ctyp=pm_type_add_mode(context,pm_tv_arg(tv,1),mode) + endif + end function pm_type_strip_literal + !================================================================ ! Autoconversion to broader poly type ! Returns -1 if not possible @@ -1978,13 +2001,12 @@ function pm_poly_type_convert(context,partyp,argtyp) result(ctyp) integer,intent(in):: partyp,argtyp integer:: ctyp type(pm_ptr):: tv1,tv2 - type(pm_type_einfo):: einfo ctyp=-1 tv1=pm_type_vect(context,partyp) tv2=pm_type_vect(context,argtyp) if(pm_tv_kind(tv1)==pm_type_is_poly.and.pm_tv_kind(tv2)==pm_type_is_poly) then if(pm_type_includes(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_type_incl_type,einfo)) then + pm_type_incl_type)) then ctyp=partyp endif endif @@ -2032,7 +2054,6 @@ function pm_proc_type_conforms(context,tno,tno2) result(ok) integer,intent(in):: tno,tno2 logical:: ok type(pm_ptr):: tv,tv2,tv_res,tv_res2 - type(pm_type_einfo):: einfo integer:: i,tno_res,tno_res2 tv=pm_type_vect(context,tno) @@ -2045,7 +2066,7 @@ function pm_proc_type_conforms(context,tno,tno2) result(ok) endif if(.not.pm_type_includes(context,pm_tv_arg(tv2,1),& - pm_tv_arg(tv,1),pm_type_incl_type,einfo)) then + pm_tv_arg(tv,1),pm_type_incl_type)) then ok=.false. return endif @@ -2059,7 +2080,7 @@ function pm_proc_type_conforms(context,tno,tno2) result(ok) return else if(.not.pm_type_includes(context,tno_res,& - tno_res2,pm_type_incl_equiv,einfo)) then + tno_res2,pm_type_incl_equiv)) then ok=.false. return endif @@ -2071,367 +2092,94 @@ end function pm_proc_type_conforms ! Find element "name" in type "tno" ! If change is true then element must be able to be modified ! Returns - ! offset==0 Error -- details in einfo + ! offset==0 Error ! offset>0 This is the offset of the element in the type - ! offset<0 Nested offsets detailed in stack(old_top:top) + ! offset<0 Returns dref rather than sub-element ! If offset/=0 then etype returns the type of the element !================================================================= - recursive function pm_type_find_elem(context,tno,name,change,& - stack,top,maxstack,etype,einfo) result(offset) + recursive function pm_type_find_elem(context,tno,name,change,etype) result(offset) type(pm_context),pointer:: context integer,intent(in):: tno,name logical,intent(in):: change - integer,dimension(:),intent(inout):: stack - integer,intent(inout):: top - integer,intent(in):: maxstack integer,intent(out):: etype - type(pm_type_einfo),intent(out):: einfo integer:: offset,ptype,mode - type(pm_ptr):: tv,tv2,nameset,info - integer:: tk,i,key(2),tno2,name2 - integer(pm_ln):: j - logical:: found + type(pm_ptr):: tv + integer:: tk,i if(tno<0) then offset=0 return endif if(tno==0) then offset=0 - einfo%kind=pm_type_err_elem_bad_type endif - einfo%kind=0 - einfo%typ1=tno - einfo%name=name tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) select case(tk) case(pm_type_is_all) do i=1,pm_tv_numargs(tv) - offset=pm_type_find_elem(context,pm_tv_arg(tv,i),name,change,& - stack,top,maxstack,etype,einfo) + offset=pm_type_find_elem(context,pm_tv_arg(tv,i),name,change,etype) if(offset/=0) return enddo offset=0 - einfo%kind=pm_type_err_elem_not_found return case(pm_type_is_dref) - offset=pm_type_find_elem(context,& - pm_type_strip_mode(context,pm_tv_arg(tv,1),mode),& - name,change,stack,top,& - maxstack,etype,einfo) - if(offset==0) then - return - else - offset=offset+pm_type_dref_offset - endif - call push(pm_type_new_dref) - call push(name) - call push(pm_type_add_mode(context,etype,mode)) - call push(tno) - do i=3,pm_tv_numargs(tv) - call push(pm_tv_arg(tv,i)) - enddo - etype=pm_new_type(context,stack(top-pm_tv_numargs(tv)-1:top)) - top=top-pm_tv_numargs(tv)-2 - case(pm_type_is_struct,pm_type_is_rec) - if(change.and.tk==pm_type_is_rec) then - einfo%kind=pm_type_err_elem_not_found - offset=0 - return - endif - call elem_offset(context,tv,name,change,offset,etype) - if(offset>0) return - if(offset<0) then - call indirect_offset(context,tv,name,stack,& - maxstack,top,change,etype,ptype,einfo) - if(einfo%kind==0) then - offset=-top - return - else - offset=0 - return - endif - else - einfo%kind=pm_type_err_elem_not_found - offset=0 - endif +!!$ offset=pm_type_find_elem(context,& +!!$ pm_type_strip_mode(context,pm_tv_arg(tv,1),mode),& +!!$ name,change,stack,top,& +!!$ maxstack,etype) +!!$ if(offset==0) then +!!$ return +!!$ else +!!$ offset=-offset +!!$ endif +!!$ call push(pm_type_new_dref) +!!$ call push(name) +!!$ call push(pm_type_add_mode(context,etype,mode)) +!!$ call push(tno) +!!$ do i=3,pm_tv_numargs(tv) +!!$ call push(pm_tv_arg(tv,i)) +!!$ enddo +!!$ etype=pm_new_type(context,stack(top-pm_tv_numargs(tv)-1:top)) +!!$ top=top-pm_tv_numargs(tv)-2 + case(pm_type_is_rec) + call pm_type_elem_offset(context,tv,name,change,offset,etype) case default - einfo%kind=pm_type_err_elem_bad_type offset=0 return end select - contains - include 'ftypeof.inc' - include 'fesize.inc' - subroutine push(j) - integer:: j - top=top+1 - stack(top)=j - end subroutine push end function pm_type_find_elem ! Find offset and type for named element in struct/rec type ! Returns offset and type of element - ! If no such element offset=0 (or offset=-1 if embedded structs exist) - recursive subroutine elem_offset(context,tv,name,change,offset,etyp) + ! If no such element offset=0 + subroutine pm_type_elem_offset(context,tv,name,change,offset,etyp) type(pm_context),pointer:: context type(pm_ptr),intent(in):: tv integer,intent(in):: name logical,intent(in):: change integer,intent(out):: offset,etyp - integer:: j,hi,lo + integer:: j integer:: name2 type(pm_ptr):: nv offset=0 etyp=0 nv=pm_name_val(context,pm_tv_name(tv)) do j=1,pm_fast_esize(nv) - if(abs(nv%data%i(nv%offset+j))==name) then + name2=nv%data%i(nv%offset+j) + if(abs(name2)==name) then + if(change.and.name2>0) then + offset=0 + return + endif etyp=pm_tv_arg(tv,j) - offset=j+1 + offset=j return endif enddo - if(iand(pm_tv_flags(tv),pm_type_has_embedded)/=0) offset=-1 contains include 'fesize.inc' - end subroutine elem_offset + end subroutine pm_type_elem_offset - ! Find offsets to an embedded element "name" of tno - recursive subroutine indirect_offset(context,tv,name,stack,& - maxstack,top,change,etype,ptype,einfo) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: tv - integer,intent(in):: name - integer,intent(inout):: top - integer,intent(in):: maxstack - integer,dimension(maxstack),intent(inout):: stack - logical,intent(in):: change - integer,intent(out):: etype,ptype - type(pm_type_einfo),intent(out):: einfo - type(pm_ptr):: nv,tv2 - integer:: i - integer:: n,offset,new_etype,new_ptype,found_below,tk2 - integer:: name2 - logical:: found,clash_below - name2=pm_tv_name(tv) - nv=pm_name_val(context,name2) - found=.false. - found_below=0 - clash_below=.false. - do i=1,pm_fast_esize(nv) - n=nv%data%i(nv%offset+i) - if(n<0) then - new_ptype=pm_tv_arg(tv,i) - tv2=pm_type_vect(context,new_ptype) - tk2=pm_tv_kind(tv2) - if(tk2/=pm_type_is_struct.and.tk2/=pm_type_is_rec) cycle - call elem_offset(context,tv2,name,change,offset,new_etype) - if(offset>0) then - if(top+4>maxstack) then - call pm_panic('Structure embedding too complex') - endif - if(found) then - einfo%kind=pm_type_err_elem_clash - einfo%vtyp1=new_ptype - einfo%vtyp2=ptype - return - endif - call push(i+1) - call push(-n) - call push(offset) - call push(name) - etype=new_etype - ptype=new_ptype - found=.true. - elseif(offset<0.and..not.found) then - if(top+2>maxstack) then - call pm_panic('Internal limit reached - Structure embedding too complex') - endif - call push(i+1) - call push(-n) - call indirect_offset(context,tv2,name,stack,& - maxstack,top,change,new_etype,new_ptype,einfo) - if(einfo%kind==0) then - if(found_below>0) then - einfo%kind=pm_type_err_elem_clash - einfo%vtyp1=new_ptype - einfo%vtyp2=ptype - else - etype=new_etype - ptype=new_ptype - endif - found_below=found_below+1 - elseif(einfo%kind==pm_type_err_elem_clash) then - clash_below=.true. - top=top-2 - return - else ! Not found - top=top-2 - endif - endif - endif - enddo - if(clash_below.and..not.found) then - return - elseif(found_below>1.and.found) then - einfo%kind=0 - elseif(.not.found.and.found_below==0) then - einfo%kind=pm_type_err_elem_not_found - endif - contains - include 'fesize.inc' - subroutine push(j) - integer,intent(in):: j - top=top+1 - stack(top)=j - end subroutine push - end subroutine indirect_offset - - ! Check that tno includes an embedded (use..) element of tno2 - recursive subroutine pm_indirect_include(context,tno,tno2,stack,& - maxstack,top,einfo,tno_match,status) - type(pm_context),pointer:: context - integer,intent(in):: tno,tno2 - integer,intent(inout):: top - integer,intent(in):: maxstack - integer,dimension(maxstack),intent(inout):: stack - type(pm_type_einfo):: einfo - integer,intent(out):: tno_match - integer,intent(out):: status - - integer:: base,base2,tno_match1 - base=top - ! Check for match via 'use' element - if(test_indirect_include(context,+1,tno,tno2,stack,& - maxstack,base,top,einfo,tno_match)) then - base2=top - tno_match1=tno_match - ! Check for match in reverse order - if(test_indirect_include(context,-1,tno,tno2,stack,& - maxstack,base2,top,einfo,tno_match)) then - if(any(stack(base+1:base2)/=stack(base2+1:top))) then - ! Clashing elements - push error details onto stack - status=pm_elem_clash - if(top+3>maxstack) call pm_panic('Program too complex (indirect include)') - stack(top+1)=base - stack(top+2)=base2 - stack(top+3)=tno_match1 - top=top+3 - else - top=base2 - status=pm_elem_found - endif - else - call pm_panic('indirect_include') - endif - else - status=pm_elem_not_found - endif - end subroutine pm_indirect_include - - ! Does the actual work for pm_indirect_include - recursive function test_indirect_include(context,dir,tno,tno2,stack,& - maxstack,base,top,einfo,tno_match) result(ok) - type(pm_context),pointer:: context - integer,intent(in):: tno,tno2 - integer,intent(inout):: top - integer,intent(in):: dir,maxstack,base - integer,dimension(maxstack),intent(inout):: stack - type(pm_type_einfo):: einfo - integer,intent(out):: tno_match - logical:: ok - type(pm_ptr):: tv,name - integer:: i,j,start,finish,tk - integer:: n - if(tno2==0) return - tv=pm_type_vect(context,tno2) - tk=pm_tv_kind(tv) - select case(tk) - case(pm_type_is_par_kind) - ok=test_indirect_include(context,dir,tno,pm_tv_arg(tv,1),stack,& - maxstack,base,top,einfo,tno_match) - return - case(pm_type_is_any) - do i=1,pm_tv_numargs(tv) - if(.not.test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.false. - return - endif - enddo - ok=.true. - return - case(pm_type_is_all) - do i=1,pm_tv_numargs(tv) - if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.true. - return - endif - enddo - ok=.false. - return - case(pm_type_is_except) - if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,1),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.not.test_indirect_include(context,dir,tno,pm_tv_arg(tv,2),stack,& - maxstack,base,top,einfo,tno_match) - else - ok=.false. - endif - return - case(pm_type_is_struct,pm_type_is_rec) - continue - case default - ok=.false. - return - end select - - ok=.false. - if(iand(pm_tv_flags(tv),pm_type_has_embedded)/=0) then - if(top+2>maxstack) call pm_panic('Program too complex (nested embeds)') - top=top+2 - if(dir>0) then - start=1 - finish=pm_tv_numargs(tv) - else - start=pm_tv_numargs(tv) - finish=1 - endif - name=pm_name_val(context,pm_tv_name(tv)) - outer: do i=start,finish,dir - n=name%data%i(name%offset+i) - stack(top-1)=i+1 - stack(top)=n - if(n<0) then - if(pm_type_includes(context,tno,pm_tv_arg(tv,i),& - pm_type_incl_indirect,einfo)) then - ! Check that this element is not shadowed by name - do j=base+2,top-2,2 - if(stack(j)==n) cycle outer - enddo - tno_match=pm_tv_arg(tv,i) - ok=.true. - return - endif - endif - enddo outer - do i=start,finish,dir - n=name%data%i(name%offset+i) - stack(top-1)=i+1 - stack(top)=n - if(n<0) then - if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.true. - return - endif - endif - enddo - top=top-2 - endif - end function test_indirect_include ! Concrete only version of a type (used/usable only for returns from builtin functions) recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result(tno2) @@ -2449,7 +2197,7 @@ recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result tk=pm_tv_kind(tv) select case(tk) case(pm_type_is_basic,pm_type_is_single_name,& - pm_type_is_proc,pm_type_is_value,pm_type_is_fix,& + pm_type_is_proc,pm_type_is_fix_value,pm_type_is_fix,& pm_type_is_undef_result,pm_type_is_poly) tno2=tno case(pm_type_is_user) @@ -2465,7 +2213,7 @@ recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result call remake(pm_tv_numargs(tv)) end select contains - subroutine remake(n) + recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i @@ -2485,44 +2233,44 @@ subroutine remake(n) end subroutine remake end function pm_type_as_concrete - - !!! Obsolete? - recursive function pm_type_remove_params(context,tno,params) result(tno2) + ! Create a new type with with all literal values replaced by fix (if tofix is true) + ! Otherwise all fix values are changed to literal values + recursive function pm_type_change_fix_literal(context,tno,tofix) result(typ) type(pm_context),pointer:: context integer,intent(in):: tno - integer,dimension(:),intent(in):: params - integer:: tno2 + logical,intent(in):: tofix + integer:: typ type(pm_ptr):: tv - integer:: tk,argnum + integer:: tk + typ=tno tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_has_fix_or_literal)==0) return tk=pm_tv_kind(tv) - if(tk==pm_type_is_user) then - tno2=pm_user_type_body(context,tno) - elseif(tk==pm_type_is_param) then - argnum=pm_tv_name(tv) - if(params(argnum)>=0) then - tno2=params(argnum) - else - tno2=pm_tv_arg(tv,1) - endif - elseif(iand(pm_tv_flags(tv),pm_type_has_params)/=0) then + select case(tk) + case(pm_type_is_user) + typ=pm_user_type_body(context,tno) + case(pm_type_is_rec) call remake(pm_tv_numargs(tv)) - else - tno2=tno - endif + case(pm_type_is_literal_value) + if(tofix) typ=pm_new_fix_value_type(context,pm_type_val(context,tno),& + pm_tv_name(tv)) + case(pm_type_is_fix_value) + if(.not.tofix) typ=pm_new_literal_value_type(context,pm_type_val(context,tno),& + pm_tv_name(tv)) + end select contains - subroutine remake(n) + recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i a(1)=tk a(2)=pm_tv_name(tv) do i=1,n - a(i+2)=pm_type_remove_params(context,pm_tv_arg(tv,i),params) + a(i+2)=pm_type_change_fix_literal(context,pm_tv_arg(tv,i),tofix) enddo - tno2=pm_new_type(context,a) + typ=pm_new_type(context,a) end subroutine remake - end function pm_type_remove_params + end function pm_type_change_fix_literal ! Get vector of integer representation of type function pm_type_vect(context,tno) result(typ) @@ -2710,7 +2458,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t istart=1 if(present(tuple_start)) istart=tuple_start if(iand(pm_tv_flags(tv),pm_type_is_list)/=0) then - if(add_char('(:')) return + if(add_char('PM__list(')) return else if(add_char('(')) return endif @@ -2722,9 +2470,12 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(pm_tv_name(tv)/=0) then amps=pm_name_val(context,pm_tv_name(tv)) j=0 + do while(amps%data%i(amps%offset+j)0.and..not.present(noequiv)) then if(show_equiv(int(name),tno2,tno)) return endif - if(tk==pm_type_is_struct) then - if(add_char('struct ')) return - else - if(add_char('rec ')) return - endif + if(add_char('rec ')) return call pm_name_string(context,name,str(n:)) n=len_trim(str)+1 if(n>len(str)-10) return @@ -2772,7 +2515,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t do i=1,narg name=nv%data%i(nv%offset+i) if(name<0) then - if(add_char('use ')) return + if(add_char('var ')) return name=-name endif nv2=pm_name_val(context,name) @@ -2856,8 +2599,8 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t case(pm_type_is_poly) if(add_char('*')) return call bracket(1,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) - case(pm_type_is_value,pm_type_is_literal) - if(tk==pm_type_is_value) then + case(pm_type_is_fix_value,pm_type_is_literal_value) + if(tk==pm_type_is_fix_value) then if(add_char('fix(')) return else if(add_char('literal(')) return @@ -2888,7 +2631,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(add_char('fix(')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return - case(pm_type_is_unfixed) + case(pm_type_is_literal) call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char('_literal')) return case(pm_type_is_except) @@ -2985,10 +2728,12 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t case(pm_type_is_undef_result) name=pm_tv_name(tv) if(add_char('(')) return - do i=1,name-1 - if(add_char('_,')) return - enddo - if(add_char('_')) return + if(name>0) then + do i=1,name-1 + if(add_char('_,')) return + enddo + if(add_char('_')) return + endif if(add_char(')')) return case(pm_type_is_vect) if(add_char('^^(')) return @@ -3108,94 +2853,5 @@ subroutine dump_type(context,iunit,tno) iand(pm_tv_flags(tv),pm_type_has_distributed) end subroutine dump_type - ! Print out type error encoded in einfo - subroutine pm_type_error(context,einfo) - type(pm_context),pointer:: context - type(pm_type_einfo):: einfo - type(pm_ptr):: val - - if(.not.pm_main_process) return - - select case(einfo%kind) - case(pm_type_err_elem) - val=pm_name_val(context,einfo%name) - call more_error(context,'Element: '//& - trim(pm_name_as_string(context,val%data%i(val%offset+einfo%index)))) - call more_error(context,' expected: '//& - trim(pm_type_as_string(context,einfo%typ1))) - if(einfo%typ2==pm_tiny_int) then - call more_error(context,'got: undefined value') - else - call more_error(context,' got: '//& - trim(pm_type_as_string(context,einfo%typ2))) - endif - case(pm_type_err_elem_not_found) - call more_error(context,& - 'Cannot find an element named: '//& - trim(pm_name_as_string(context,einfo%name))) - call more_error(context,& - 'in type: '//& - trim(pm_type_as_string(context,einfo%typ1))) - case(pm_type_err_elem_not_in_interface) - call more_error(context,& - 'Cannot find an element named: '//& - trim(pm_name_as_string(context,einfo%name))) - call more_error(context,& - 'in interface: '//& - trim(pm_type_as_string(context,einfo%typ1))) - call more_error(context,'or any of its parent interfaces') - case(pm_type_err_elem_bad_type) - call more_error(context,& - 'Type: '//& - trim(pm_type_as_string(context,einfo%typ1))) - call more_error(context,& - 'does not have any elements -- cannot apply "." operator') - case(pm_type_err_elem_clash) - call more_error(context,& - 'Type: '//trim(pm_type_as_string(context,einfo%typ1))) - call more_error(context,& - ' embeds: '//& - trim(pm_type_as_string(context,einfo%vtyp1))//'.'//& - trim(pm_name_as_string(context,einfo%name))) - call more_error(context,& - ' also embeds: '//& - trim(pm_type_as_string(context,& - einfo%vtyp2))//'.'//& - trim(pm_name_as_string(context,einfo%name))) - case default - call more_error(context, 'Expected: '//& - trim(pm_type_as_string(context,einfo%typ1))) - if(einfo%typ2==pm_tiny_int.or.einfo%typ2<0) then - call more_error(context,'Got: undefined value') - else - call more_error(context,'Got: '//& - trim(pm_type_as_string(context,einfo%typ2))) - endif - end select - end subroutine pm_type_error - - ! Error message for ambiguous match - ! (assumes wstack holds results from pm_indirect_include) - subroutine pm_type_ambiguous_match_error(context,pt,at,at2,wstack,wtop) - type(pm_context),pointer:: context - integer,intent(in):: pt,at,at2,wtop - integer,intent(in),dimension(:):: wstack - call more_error(context,' expecting: '//& - trim(pm_type_as_string(context,pt))) - call more_error(context,' got: '//& - trim(pm_type_as_string(context,& - pm_user_type_body(context,at)))) - call more_error(context,' first match: '//& - trim(pm_name_vect_as_string(context,& - wstack(wstack(wtop-1)+2:wtop-3),2))) - call more_error(context,' of type: '//& - trim(pm_type_as_string(context,at2))) - call more_error(context,' second match: '//& - trim(pm_name_vect_as_string(context,& - wstack(wstack(wtop-2)+2:& - wstack(wtop-1)),2))) - call more_error(context,' of type: '//& - trim(pm_type_as_string(context,wstack(wtop)))) - end subroutine pm_type_ambiguous_match_error end module pm_types diff --git a/src/vm.f90 b/src/vm.f90 index 6aacb8e..e7878e1 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -189,7 +189,7 @@ recursive function pm_run(context,funcin,stackin,pcin,& endif endif - if(opcode==op_comm_call) then + if(opcode==op_comm_call.and..false.) then oparg=pc%data%i16(pc%offset+4_pm_p) arg(2)=stack%data%ptr(stack%offset+oparg) ve=arg(2)%data%ptr(arg(2)%offset+1) @@ -321,19 +321,19 @@ recursive function pm_run(context,funcin,stackin,pcin,& endif select case(opcode) - case(op_call) + case(op_call,op_comm_call) ! op_call #proc ve args... ! op_comm_call #proc ve args... newfunc=context%funcs%data%ptr(& context%funcs%offset+opcode2) if(run_call(newfunc)) goto 999 - case(op_comm_call) - ve=arg(2)%data%ptr(arg(2)%offset+1) - esize=ve%data%ln(ve%offset) - ve=arg(2)%data%ptr(arg(2)%offset) - newfunc=context%funcs%data%ptr(& - context%funcs%offset+opcode2) - if(run_call(newfunc)) goto 999 +!!$ case(op_comm_call) +!!$ ve=arg(1)%data%ptr(arg(1)%offset+1) +!!$ esize=ve%data%ln(ve%offset) +!!$ ve=arg(1)%data%ptr(arg(1)%offset) +!!$ newfunc=context%funcs%data%ptr(& +!!$ context%funcs%offset+opcode2) +!!$ if(run_call(newfunc)) goto 999 case(op_skip_empty) ! op_skip_empty #0_or_2 ve &newve ! op_skip_empty #1 ve &newve oldve @@ -1181,7 +1181,12 @@ recursive function pm_run(context,funcin,stackin,pcin,& enddo endif case(op_nullify) - call set_arg(2,pm_null_obj) + do i=2,nargs + call set_arg(i,pm_null_obj) + enddo + case(op_number) + ibuffer(1)=opcode2 + call fill_args_from_ibuffer(2,2,ibuffer) case(op_clone_ve) stack%data%ptr(stack%offset+opcode2)=arg(1) case(op_logical_return) @@ -1267,18 +1272,39 @@ recursive function pm_run(context,funcin,stackin,pcin,& errno=0 call vector_assign(context,arg(2),arg(3),ve,errno,esize) if(errno/=0) goto 997 - case(op_struct) - v=pm_fast_newusr(context,pm_struct_type,int(nargs,pm_p)) + case(op_struct,op_rec) + v=pm_fast_newusr(context,pm_rec_type,int(nargs,pm_p)) call set_arg(2,v) v%data%ptr(v%offset+1_pm_p)=& pm_fast_tinyint(context,opcode2) v%data%ptr(v%offset+2:v%offset+nargs-1)=arg(3:nargs) - case(op_rec) - v=pm_fast_newusr(context,pm_rec_type,int(nargs,pm_p)) + case(op_list_concat) + j=pm_fast_esize(arg(3)) + jj=pm_fast_esize(arg(4)) + v=pm_fast_newusr(context,pm_rec_type,j+jj) + call set_arg(2,v) + v%data%ptr(v%offset:v%offset+j)=arg(3)%data%ptr(arg(3)%offset:arg(3)%offset+j) + v%data%ptr(v%offset+j+1:v%offset+pm_fast_esize(v))=& + arg(4)%data%ptr(arg(4)%offset+2:arg(4)%offset+jj) + case(op_list_splice) + j=pm_fast_esize(arg(3)) + jj=pm_fast_esize(arg(4)) + i=arg(5)%data%ln(arg(5)%offset) + ii=arg(6)%data%ln(arg(6)%offset) + v=pm_fast_newusr(context,pm_rec_type,int(j+jj-1-ii,pm_p)) call set_arg(2,v) v%data%ptr(v%offset+1_pm_p)=& pm_fast_tinyint(context,opcode2) - v%data%ptr(v%offset+2:v%offset+nargs-1)=arg(3:nargs) + if(i>0) then + v%data%ptr(v%offset+2:v%offset+i+1)=& + arg(3)%data%ptr(arg(3)%offset+2:arg(3)%offset+i+1) + endif + v%data%ptr(v%offset+i+2:v%offset+i+jj)=& + arg(4)%data%ptr(arg(4)%offset+2:arg(4)%offset+jj) + if(i=0) then newve=pm_assign_new(context,newve,1_pm_ln,pm_long,n+4_pm_ln,.false.) newve%data%ln(newve%offset)=m @@ -10425,7 +10452,7 @@ function pm_arglist_type(context,tkind,tname,args,nargs) result(tno) t(2)=tname do i=1,nargs tno=pm_fast_typeof(args(i)) - if(tno>=pm_struct_type.and.tno<=pm_array_type) then + if(tno>=pm_rec_type.and.tno<=pm_array_type) then tno=args(i)%data%ptr(args(i)%offset+1_pm_p)%offset endif t(i+2)=tno @@ -10444,7 +10471,7 @@ function pm_arg_type(arg) result(tno) type(pm_ptr),intent(in):: arg integer(pm_i16):: tno tno=pm_fast_typeof(arg) - if(tno>=pm_struct_type.and.tno<=pm_elemref_type) then + if(tno>=pm_rec_type.and.tno<=pm_elemref_type) then tno=arg%data%ptr(arg%offset+1_pm_p)%offset endif contains diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 1a82b18..6f83a9b 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -109,8 +109,10 @@ module pm_vmdefs integer,parameter:: op_check_logical = op_misc + 25 integer,parameter:: op_chan_array_elem = op_misc + 26 integer,parameter:: op_chan_array_vect = op_misc + 27 + integer,parameter:: op_list_concat = op_misc + 28 + integer,parameter:: op_list_splice = op_misc + 29 - integer,parameter:: op_misc2=op_chan_array_vect + integer,parameter:: op_misc2=op_list_splice integer,parameter:: op_array_get_elem = op_misc2 + 1 integer,parameter:: op_array_set_elem = op_misc2 + 2 @@ -240,7 +242,8 @@ module pm_vmdefs integer,parameter:: op_nullify = first_assign_op + 6 integer,parameter:: op_assign = first_assign_op + 7 integer,parameter:: op_fill = first_assign_op + 8 - integer,parameter:: last_assign_op = first_assign_op+8 + integer,parameter:: op_number = first_assign_op + 9 + integer,parameter:: last_assign_op = first_assign_op+9 integer,parameter:: op_eq = last_assign_op +1 integer,parameter:: op_ne = last_assign_op +2 @@ -693,6 +696,7 @@ module pm_vmdefs integer,parameter:: num_op=op_stop_comp + integer,parameter:: last_fold=-1 integer,parameter:: op_add_fold=-1 integer,parameter:: op_sub_fold=-2 integer,parameter:: op_mult_fold=-3 @@ -723,7 +727,9 @@ module pm_vmdefs integer,parameter:: op_concat_fold = -28 integer,parameter:: op_num_elems_fold = -29 integer,parameter:: op_type_include_fold = -30 - integer,parameter:: min_op=op_type_include_fold + integer,parameter:: first_fold=-30 + integer,parameter:: op_clone_var = -31 + integer,parameter:: min_op=op_clone_var integer,dimension(0:num_op):: op_flags integer,parameter:: op_is_call=1 @@ -817,6 +823,8 @@ module pm_vmdefs data op_flags(op_extract_first) /0/ data op_flags(op_chan_array_elem) /0/ data op_flags(op_chan_array_vect) /0/ + data op_flags(op_list_concat) /0/ + data op_flags(op_list_splice) /0/ data op_flags(op_array_get_elem) /0/ data op_flags(op_array_set_elem) /0/ @@ -940,6 +948,7 @@ module pm_vmdefs data op_flags(op_nullify) /0/ data op_flags(op_assign) /0/ data op_flags(op_fill) /0/ + data op_flags(op_number) /0/ data op_flags(op_eq) /op_is_arith/ data op_flags(op_ne) /op_is_arith/ @@ -1518,6 +1527,8 @@ subroutine set_op_names op_names(op_extract_first)='extract_first' op_names(op_chan_array_elem)='chan_array_elem' op_names(op_chan_array_vect)='chan_array_vect' + op_names(op_list_concat)='list_concat' + op_names(op_list_splice)='list_splice' op_names(op_array_get_elem)='array_get_elem' op_names(op_array_set_elem)='array_set_elem' @@ -1641,6 +1652,7 @@ subroutine set_op_names op_names(op_nullify)='nullify' op_names(op_assign)='assign' op_names(op_fill)='fill' + op_names(op_number)='number' op_names(op_eq)='eq' op_names(op_ne)='ne' @@ -2099,6 +2111,7 @@ subroutine set_op_names op_names(op_concat_fold)='concat_fold' op_names(op_num_elems_fold)='num_elems_fold' op_names(op_type_include_fold)='type_include_fold' + op_names(op_clone_var)='clone_var' !!$ do i=op_call,op_comm_loop_par !!$ if(op_names(i)=='??')then @@ -2435,7 +2448,7 @@ recursive subroutine printv(index,addtype) call append(')') tno2=var(v1+2)/cvar_flag_mult tk=pm_type_kind(context,tno2) - if(tk==pm_type_is_struct.or.tk==pm_type_is_rec) then + if(tk==pm_type_is_rec) then ename=abs(pm_type_elem_name(context,tno2,v2)) if(ename>=sym_d1.and.ename<=sym_d7) then call append('.'//pm_int_as_string(v2)) @@ -2477,7 +2490,7 @@ recursive subroutine printv(index,addtype) call group(index,v1,v2,'<','>',.false.) case(v_is_struct) tk=pm_type_kind(context,tno) - if(tk==pm_type_is_struct.or.tk==pm_type_is_rec) then + if(tk==pm_type_is_rec) then call group(index,v1,v2,trim(pm_name_as_string(context,pm_type_elem_name(context,tno,0)))//& '{','}',.false.) else diff --git a/src/wcoder.f90 b/src/wcoder.f90 index f779f8e..4eb806d 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2024 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -49,6 +49,7 @@ module pm_wcode integer,parameter:: max_const=2**15-1-pm_max_args integer,parameter:: max_costack=2**15-1 + integer,parameter:: max_par_depth=256 integer,parameter:: max_comm_par_depth=256 integer,parameter:: max_labels=1024 @@ -95,10 +96,6 @@ module pm_wcode integer,dimension(2):: cotop type(costate),dimension(2,max_costack):: costack integer:: cs - - ! Loop stack - integer,dimension(0:max_par_depth):: lstack - integer:: ltop,lbase ! Labels integer:: labels(1:max_labels) @@ -106,8 +103,7 @@ module pm_wcode ! Current proc integer:: loop_extra_arg - logical:: proc_can_inline,proc_is_chan - logical:: proc_shared_inline + logical:: proc_can_inline ! Inlining type(pm_ptr):: inline_args,inline_keys,inline_key_names,outer_rv @@ -126,12 +122,15 @@ module pm_wcode ! Last coded instruction (compiling only) integer:: last_instr + ! Vector engines for current parallel context + integer:: shared_ve + ! Stack of nested communicating sequential loops (compiling only) integer,dimension(max_comm_par_depth):: loop_stack integer:: loop_top ! Return and parameter values (compiling only) - integer:: retvar,pvar,vevar + integer:: retvar,pvar type(pm_ptr):: keys ! Set of active types (compiling only) @@ -172,8 +171,8 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) wcd%true_obj%data%l(wcd%true_obj%offset)=.true. wcd%false_obj=pm_new_small(context,pm_logical,1_pm_p) wcd%false_obj%data%l(wcd%false_obj%offset)=.false. - wcd%true_name=pm_new_fix_type(wcd%context,wcd%true_obj) - wcd%false_name=pm_new_fix_type(wcd%context,wcd%false_obj) + wcd%true_name=pm_new_fix_value_type(wcd%context,wcd%true_obj) + wcd%false_name=pm_new_fix_value_type(wcd%context,wcd%false_obj) if(pm_is_compiling) then wcd%typeset=pm_set_new(wcd%context,32_pm_ln) endif @@ -212,12 +211,8 @@ subroutine wcode_prog(wcd,p) rv=cnode_arg(p,2) wcd%base=0 wcd%top=pm_fast_esize(rv)+1 - wcd%ltop=0 init_ve=merge(0,pm_stack_nullve,pm_is_compiling) - wcd%lstack(wcd%ltop)=init_ve wcd%proc_can_inline=.true. - wcd%proc_is_chan=.false. - wcd%proc_shared_inline=.false. ve=init_ve break=wcode_cblock(wcd,cblock,rv,ve) if(pm_is_compiling) then @@ -255,24 +250,17 @@ subroutine wcode_procs(wcd) pr=cnode_arg(proc,1) rv=cnode_arg(proc,2) taints=cnode_arg(proc,3) - keys=cnode_arg(proc,4) - wcd%lstack(wcd%ltop)=merge(0,pm_stack_nullve,pm_is_compiling) - wcd%lbtop=0 - wcd%lbbase=0 - wcd%ltop=wcd%ltop+1 + !keys=cnode_arg(proc,4) if(pm_is_compiling) then ve=0 else ve=alloc_var(wcd,pm_ve_type) endif - wcd%lstack(wcd%ltop)=ve wcd%loop_extra_arg=iand(cnode_get_num(pr,pr_flags),proccall_is_comm) wcd%proc_can_inline=cnode_flags_clear(proc,& cnode_args+2,proc_is_not_inlinable) - wcd%proc_is_chan=cnode_flags_set(pr,pr_flags,proc_run_complete) - wcd%proc_shared_inline=.false. wcd%npar=cnode_get_num(pr,pr_nret)+wcd%loop_extra_arg - if(pm_is_compiling) then + if(pm_is_compiling) then if(rv%data%i(rv%offset)==-1) then wcd%retvar=alloc_result_var(wcd,int(pm_null)) else @@ -290,20 +278,25 @@ subroutine wcode_procs(wcd) !!$ endif if(wcd%loop_extra_arg/=0) then if(vev>0) then - wcd%vevar=cvar_alloc_entry(wcd,v_is_parve,0,0,int(pm_logical)) + wcd%shared_ve=cvar_alloc_entry(wcd,v_is_parve,0,0,int(pm_logical)) else - wcd%vevar=-1 + wcd%shared_ve=ve endif endif else wcd%nvar=wcd%npar+1 wcd%avar=wcd%npar+1 wcd%ref_count(1:wcd%nvar)=1 + if(wcd%loop_extra_arg/=0) then + wcd%shared_ve=pm_stack_locals+5 + else + wcd%shared_ve=ve + endif endif if(debug_wcode) then write(*,*) 'WCODE PROC> #',i,'SIGNO>',n,'VE>',ve,& 'NRET>',wcd%npar,'NVAR>',wcd%nvar,& - 'CAN INLINE> ',wcd%proc_can_inline,'CHAN>',wcd%proc_is_chan,& + 'CAN INLINE> ',wcd%proc_can_inline,& 'EXTRA>',wcd%loop_extra_arg endif cblock=cnode_get(pr,pr_cblock) @@ -338,8 +331,6 @@ subroutine init_wcode_proc(wcd,proc) wcd%mvar=0 wcd%avar=0 wcd%npar=0 - wcd%lbase=0 - wcd%ltop=0 wcd%base=0 wcd%top=pm_fast_esize(cnode_arg(proc,2))+1 wcd%xbase=wcd%top @@ -361,7 +352,7 @@ subroutine init_wcode_proc(wcd,proc) wcd%inline_none=.false. wcd%retvar=-1 wcd%pvar=-1 - wcd%vevar=-1 + wcd%shared_ve=0 wcd%keys=pm_null_obj contains include 'fesize.inc' @@ -416,7 +407,7 @@ end subroutine make_proc_code !==================================================== ! Make proc object (compiler version) ! - wcode vars taints keys values... - ! - wcode is retvar, pvar, name, vevar, wcodes... + ! - wcode is retvar, pvar, name, shared_ve, wcodes... !==================================================== subroutine make_proc_code_comp(wcd,i,name,nret,taints,keys,ve) type(wcoder),intent(inout):: wcd @@ -446,7 +437,7 @@ subroutine make_proc_code_comp(wcd,i,name,nret,taints,keys,ve) p2%data%i(p2%offset)=wcd%retvar p2%data%i(p2%offset+1)=wcd%pvar p2%data%i(p2%offset+2)=name - p2%data%i(p2%offset+3)=wcd%vevar + p2%data%i(p2%offset+3)=wcd%shared_ve p2%data%i(p2%offset+4:p2%offset+wcd%pc+2)=wcd%wc(1:wcd%pc-1) p2=pm_assign_new(wcd%context,wcd%temp,& 1_pm_ln,pm_int,int(max(1,wcd%nvar),pm_ln),.false.) @@ -521,15 +512,13 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) do while(cnode_flags_set(p,var_flags,var_is_param)) slot=cnode_get_num(p,var_index) typ=get_var_type(wcd,p,rv) - isshared=cnode_get_num(p,var_par_depth)==1 isref=cnode_flags_set(p,var_flags,var_is_ref) if(debug_wcode) then write(*,*) 'ALLOCATING PARAM>',& - trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))),& - ' depth',cnode_get_num(p,var_par_depth) + trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))) endif wcd%rdata(slot+wcd%base)=alloc_param_var(wcd,& - typ,isref,.false.,isshared,cnode_get_num(p,var_name)) + typ,isref,.false.,cnode_get_num(p,var_name)) if(debug_wcode) write(*,*) 'TO>',wcd%rdata(slot+wcd%base) npar=npar+1 @@ -544,7 +533,7 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) xpar=pm_tv_numargs(tv) do i=1,xpar typ=pm_tv_arg(tv,i) - slot=alloc_param_var(wcd,typ,.false.,.false.,.false.,0) + slot=alloc_param_var(wcd,typ,.false.,.false.,0) if(typ/=pm_tiny_int) then wcd%top=wcd%top+1 wcd%rdata(wcd%top)=slot @@ -560,7 +549,7 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) endif npar=npar+xpar else - slot=alloc_param_var(wcd,typ,.false.,.false.,.false.,0) + slot=alloc_param_var(wcd,typ,.false.,.false.,0) if(typ/=pm_tiny_int) then wcd%top=wcd%top+1 wcd%rdata(wcd%top)=slot @@ -787,7 +776,7 @@ end subroutine close_vars !========================================================== ! Wcode a call node (which includes control structures) !========================================================== - function wcode_call(wcd,callnode,rv,ve,restart) result(break) + recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) type(wcoder),intent(inout):: wcd type(pm_ptr),intent(in):: callnode,rv integer,intent(in):: ve @@ -909,22 +898,22 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) new_ve=0 if(tno==wcd%true_name) then call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) elseif(tno==wcd%false_name) then if(.not.pm_fast_isnull(cnode_arg(args,3))) then call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) endif else call wc_call(wcd,callnode,op_if,0,4,0,ve) pc=comp_start_if_else_block(wcd) call wc_arg(wcd,cnode_arg(args,1),.false.,rv,ve) call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) if(.not.pm_fast_isnull(cnode_arg(args,3))) then call comp_start_else_block(wcd,pc) call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) call comp_finish_else_block(wcd,pc) else call comp_finish_block(wcd,pc) @@ -940,7 +929,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) pm_fast_isnull(cnode_arg(args,3)),rv,ve) jmp=wc_jump_call(wcd,callnode,op_skip_comms,0,1,new_ve) call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) call set_jump_to_here(wcd,jmp) endif if(tno/=wcd%true_name) then @@ -951,7 +940,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,1),.false.,rv,ve) jmp=wc_jump_call(wcd,callnode,op_skip_comms,0,1,new_ve) call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) call set_jump_to_here(wcd,jmp) endif call release_var(wcd,new_ve) @@ -1024,31 +1013,6 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,2),.false.,rv,new_ve) call release_var(wcd,new_ve) endif - case(sym_each) - if(restart) return - if(cblock_has_comm(cnode_arg(args,2))) then - break=.true. - return - endif - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_loop,0,3,0,ve) - pc=comp_start_block(wcd) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,0) - call comp_finish_block(wcd,pc) - else - new_ve=alloc_var(wcd,pm_ve_type) - call wc_call(wcd,callnode,op_clone_ve,int(new_ve),1,1,ve) - jmp=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) - pc=wcd%pc - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) - call set_jump_to_here(wcd,jmp) - call wc_call(wcd,callnode,op_and_jmp_any,& - pc,3,0,new_ve) - call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) - call release_var(wcd,new_ve) - endif case(sym_over) call wc_call(wcd,callnode,op_over,0,2,0,ve) pc=comp_start_block(wcd) @@ -1071,57 +1035,10 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) return case(sym_for,sym_also) call wcode_comm_block(wcd,cnode_arg(args,1),& - wcd%lstack(wcd%ltop-1),rv,ve) + wcd%shared_ve,rv,ve) case(sym_pct) - if(nargs==1) then - n=1 - else - n=2 - if(.not.pm_is_compiling) then - call wc_call(wcd,callnode,op_setref,0,3,1,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - call wc(wcd,pm_stack_locals+1) - endif - endif - save_xbase=wcd%xbase - save_top=wcd%top - wcd%lstack(wcd%ltop)=ve - wcd%ltop=wcd%ltop+1 - save_lbtop=wcd%lbtop - if(wcd%ltop>max_par_depth) & - call pm_panic('program too complex (nested for/par statements)') - if(pm_is_compiling) then - new_ve=max(0,wcd%vevar) - if(wcd%base==0) then - call wc_simple_comp_call(wcd,op_comm_proc,0,2,ve) - pc=comp_start_block(wcd) - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - call comp_finish_block(wcd,pc) - else - if(wcd%proc_is_chan) new_ve=0 - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - endif - else - if(wcd%base==0) then - new_ve=pm_stack_locals+1 - else - new_ve=wcd%vevar - endif - if(wcd%proc_is_chan) then - call wc_simple_call(wcd,op_chan,1,2,new_ve) - new_ve=alloc_var(wcd,pm_ve_type) - call wc(wcd,-new_ve) - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - call release_var(wcd,new_ve) - else - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - endif - endif - wcd%ltop=wcd%ltop-1 - if(wcd%xbase>save_xbase) call release_import_varg(save_top) - wcd%xbase=save_xbase - wcd%top=save_top - wcd%lbtop=save_lbtop + call wcode_comm_block(wcd,cnode_arg(args,2),& + wcd%shared_ve,rv,ve) case(sym_hash) if(check_arg_type(wcd,args,rv,2)/=pm_null) then break=wcode_cblock(wcd,cnode_arg(args,1),rv,ve) @@ -1320,10 +1237,25 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call_args(wcd,callnode,args,op_dref,& merge(0,1,sig==sym_pm_dref.or.sig==sym_pm_dref_slice),nargs,1,rv,ve) endif - case(sym_for_stmt) - call for_statement + case(sym_pm_for) + call pm_for(cnode_arg(args,1),cnode_arg(args,2),ve) + case(sym_pm_shared_always) + new_ve=wcd%shared_ve + break=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) + case(sym_pm_shared) + new_ve=alloc_var(wcd,pm_ve_type) + call wc_call(wcd,callnode,op_skip_empty,0,3,0,ve) + call wc(wcd,-new_ve) + call wc(wcd,wcd%shared_ve) + break=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) + case(sym_pm_chan,sym_pm_chan_always) + new_ve=alloc_var(wcd,pm_ve_type) + call wc_call(wcd,callnode,op_chan,0,2,0,ve) + call wc(wcd,-new_ve) case(sym_any) call any_statement + case(sym_pm_each_index) + call each_index_statement case(sym_pval,sym_pval_as) if(pm_is_compiling) then tno=check_arg_type(wcd,args,rv,3) @@ -1345,7 +1277,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_make_type_val,tno,2,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) endif - case(sym_struct,sym_rec) + case(sym_rec) if(pm_is_compiling) then i=arg_slot(wcd,cnode_arg(args,1)) if(cvar_kind(wcd,i)==v_is_group) then @@ -1367,7 +1299,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif else typ=check_arg_type(wcd,args,rv,1) - call wc_call(wcd,callnode,op_struct+sig-sym_struct,& + call wc_call(wcd,callnode,op_rec,& typ,nargs-1,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) do kk=4,nargs @@ -1375,9 +1307,9 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,kk),.false.,rv,ve) enddo endif - case(sym_open_smiley) + case(sym_pm_list) typ=check_arg_type(wcd,args,rv,1) - call wc_call_args(wcd,callnode,args,op_struct,typ,& + call wc_call_args(wcd,callnode,args,op_rec,typ,& nargs,1,rv,ve) case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref,sym_method_call) i=rvv(cnode_get_num(callnode,call_index)) @@ -1387,13 +1319,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) else j=op_elem endif - if(i>0) then - call wc_args_get_elem(wcd,callnode,j,args,int(i),rv,ve) - elseif(i<0) then - v=pm_dict_val(wcd%context,wcd%sig_cache,int(-i,pm_ln)) - call wc_sub_elem(wcd,callnode,j,cnode_arg(args,1),cnode_arg(args,2),& - v%data%i,v%offset+1,v%offset+pm_fast_esize(v),rv,ve) - endif + call wc_args_get_elem(wcd,callnode,j,args,i,rv,ve) case(sym_test) if(pm_opts%check_stmts) then if(restart) then @@ -1498,30 +1424,6 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) cnode_arg(args,i*2+n+n),wcd%base,rv,ve) enddo outer endif - -!!$ v=cnode_arg(cnode_arg(args,2),1) -!!$ idx=v%data%i(v%offset) -!!$ if(wcd%base==0) then -!!$ if(pm_is_compiling) then -!!$ wcd%rdata(cnode_get_num(cnode_arg(args,1),var_index)+wcd%base)=& -!!$ -wcd%keys%data%i(wcd%keys%offset+idx-1) -!!$ else -!!$ v=cnode_arg(cnode_arg(args,3),1) -!!$ idx=idx+v%data%i(v%offset)+wcd%loop_extra_arg -!!$ call wc_call_args(wcd,callnode,args,op_get_key2,& -!!$ idx+pm_stack_locals,1,1,rv,ve) -!!$ endif -!!$ else -!!$ call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& -!!$ cnode_arg(wcd%inline_args,idx+wcd%keybase),wcd%oldbase,& -!!$ rv,ve) -!!$ endif -!!$ case(sym_default) -!!$ call wc_call_args(wcd,callnode,args,op_default,& -!!$ check_arg_type(wcd,args,rv,1),1,1,rv,ve) - case(sym_init_var) - call wc_call(wcd,callnode,op_init_var,0,2,1,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) case(sym_is) if(check_arg_type(wcd,args,rv,1)==wcd%true_name) then call wc_call(wcd,callnode,op_logical_return,1,2,1,ve) @@ -1539,24 +1441,19 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) var_slot(wcd,cnode_arg(args,kk))) enddo endif - case(sym_private,sym_set_mode,sym_const,sym_var,sym_null,& + case(sym_private,sym_set_mode,sym_const,sym_var,& sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_assignment) continue ! Nothing to do + case(sym_null) + call wc_call_args(wcd,callnode,args,op_nullify,0,nargs,nargs,rv,ve) case(sym_cast) i=rvv(cnode_get_num(callnode,call_index)) if(i==0) then call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) else - v=pm_dict_val(wcd%context,wcd%sig_cache,int(i,pm_ln)) - v=cnode_arg(v,1) - if(pm_fast_esize(v)==0) then - call wc_call_args(wcd,callnode,args,op_make_poly,& - v%data%i(v%offset),3,1,rv,ve) - else - call wc_sub_elem(wcd,callnode,op_elem,cnode_arg(args,1),cnode_arg(args,2),& - v%data%i,v%offset,v%offset+pm_fast_esize(v),rv,ve) - endif + call wc_call_args(wcd,callnode,args,op_make_poly,& + i,3,1,rv,ve) endif case(sym_dcaret) if(pm_is_compiling) then @@ -1572,83 +1469,20 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) endif - case(sym_dash,sym_caret,sym_change_mode) + case(sym_fix,sym_literal,sym_caret,sym_change_mode) call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) - case(sym_import_val,sym_import_shared) - if(pm_is_compiling) then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - elseif(call_flag_set(wcd,callnode,rv)) then - if(nret==0) then - call wc_call_args(wcd,callnode,args,op_import_back,0,nargs,0,rv,ve) - else - call wc_call_args(wcd,callnode,args,op_import_val,0,nargs,1,rv,ve) - endif - elseif(nret>0)then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - case(sym_import_param) - if(call_flag_set(wcd,callnode,rv).and..not.pm_is_compiling) then - if(wcd%base==0) then - new_ve=pm_stack_locals+1 - else - new_ve=wcd%vevar - endif - call wc_call_args(wcd,callnode,args,op_import_val,0,nargs,1,rv,new_ve) - else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - case(sym_import_varg) - if(.not.pm_is_compiling) then - if(call_flag_set(wcd,callnode,rv)) then - n=wcd%top-wcd%xbase - if(wcd%top+n>max_code_stack) call pm_panic('out of code stack') - do i=1,n -!!! Note this is not right type (for vm only does not matter) - wcd%rdata(wcd%top+i)=alloc_var(wcd,pm_ve_type) - enddo - do i=1,n - call wc_call(wcd,callnode,op_import_val,0,3,1,ve) - call wc(wcd,-wcd%rdata(wcd%top+i)) - call wc(wcd,wcd%rdata(wcd%xbase+i)) - enddo - wcd%xbase=wcd%xbase+n - wcd%top=wcd%top+n - endif - endif - case(sym_export) - if(.not.pm_is_compiling) then - if(call_flag_set(wcd,callnode,rv)) then - call wc_call_args(wcd,callnode,args,op_export,0,nargs,0,rv,ve) - endif - endif - case(sym_export_as_new) - if(call_flag_set(wcd,callnode,rv).and..not.pm_is_compiling) then - call wc_call_args(wcd,callnode,args,op_export_param,0,nargs,1,rv,ve) - else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - case(sym_export_param) - if(pm_is_compiling) then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - else - if(wcd%base==0) then - new_ve=pm_stack_locals+1 - else - new_ve=wcd%vevar - endif - if(call_flag_set(wcd,callnode,rv)) then - call wc_call_args(wcd,callnode,args,op_export_param,0,nargs,1,rv,new_ve) - else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - endif + case(sym_pm_set_dotdotdot) + wcd%xbase=wcd%top + tno=get_arg_type(wcd,cnode_arg(args,2),rv) + tv=pm_type_vect(wcd%context,tno) + do i=1,pm_tv_numargs(tv) + call wc_call(wcd,callnode, op_elem,i+1,3,1,ve) + wcd%top=wcd%top+1 + wcd%rdata(wcd%top)=alloc_var(wcd,pm_tv_arg(tv,i)) + call wc(wcd,-wcd%rdata(wcd%top)) + call wc(wcd,arg_slot(wcd,cnode_arg(args,2))) + enddo case(sym_result) if(wcd%base==0) then if(pm_is_compiling) then @@ -1688,7 +1522,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) if((cvar_kind(wcd,slot)/=v_is_group.or.& cvar_kind(wcd,slot)==v_is_group.and.& cvar_v2(wcd,slot)/=v_is_array).and.& - wcd%loop_extra_arg==0.and..not.wcd%proc_shared_inline.and.& + wcd%loop_extra_arg==0.and.& pm_type_get_mode(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))>=sym_invar& .or.cvar_kind(wcd,slot2)==v_is_chan_vect) then @@ -1739,16 +1573,9 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) else nkeys=cnode_numargs(cnode_get(callnode,call_keys)) endif - if(cnode_flags_clear(callnode,call_flags,proccall_is_comm)) then - call wcode_proc_call(wcd,callnode,rv,ve,-1,& - args,nargs,totargs,nkeys,nret,sig) -!!$ elseif(pm_is_compiling) then -!!$ break=.true. -!!$ return - else - call wcode_proc_call(wcd,callnode,rv,wcd%lstack(max(0,wcd%ltop-1)),ve,& - args,nargs,totargs,nkeys,nret,sig) - endif + call wcode_proc_call(wcd,callnode,rv,ve,merge(wcd%shared_ve,-1,& + cnode_flags_set(callnode,call_flags,proccall_is_comm)),& + args,nargs,totargs,nkeys,nret,sig) end select if(debug_wcode) then if(sig>0) then @@ -1765,82 +1592,39 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) include 'fesize.inc' include 'fvkind.inc' - subroutine for_statement - break2=wcode_cblock(wcd,cnode_arg(args,4),rv,ve) - if(break2) then - call wcode_error(wcd,callnode,& - 'Cannot have communicating operations in partition/workshare') - endif - if(check_arg_type(wcd,args,rv,2)==pm_null) then - call for_body(ve) - else - v=cnode_arg(args,8) - v=cnode_arg(v,1) - slot=v%data%i(v%offset) - slot2=v%data%i(v%offset+1) - u=pm_dict_val(wcd%context,wcd%sig_cache,int(& - rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) - v=cnode_arg(u,1) - rv%data%i(rv%offset+slot:rv%offset+slot2)=& - v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_if_shared_node,0,3,0,ve) - pc=comp_start_if_else_block(wcd) - else - pc=wc_jump_call(wcd,callnode,op_jmp_noshare,0,1,ve) - endif - call for_body(merge(0,ve,pm_is_compiling)) - v=cnode_arg(u,2) - rv%data%i(rv%offset+slot:rv%offset+slot2)=& - v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - call comp_start_else_block(wcd,pc) - if(wcd%num_errors==0) call for_body(0) - call comp_finish_else_block(wcd,pc) - else - jmp=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) - call set_jump_to_here(wcd,pc) - if(wcd%num_errors==0) call for_body(ve) - call set_jump_to_here(wcd,jmp) - endif - endif - end subroutine for_statement - - subroutine for_body(ve) - integer:: j,ve - integer:: save_xbase,save_top + subroutine pm_for(arg,stmts,ve) + type(pm_ptr),intent(in):: arg,stmts + integer,intent(in):: ve + integer:: j,new_ve,save_xbase,save_lbtop,save_top,save_shared_ve save_xbase=wcd%xbase save_top=wcd%top if(.not.pm_is_compiling) then + new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_par_loop,0,3,1,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,6),.false.,rv,ve) + call wc(wcd,-new_ve) + call wc_arg(wcd,arg,.false.,rv,ve) j=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) - new_ve=var_slot(wcd,cnode_arg(args,1)) else call wc_simple_comp_call(wcd,op_comm_block,0,3,ve) j=comp_start_block(wcd) call wc_arg(wcd,cnode_arg(args,6),.false.,rv,ve) new_ve=0 endif - wcd%lstack(wcd%ltop)=ve - wcd%ltop=wcd%ltop+1 - if(wcd%ltop>max_par_depth) & - call pm_panic('program too complex (nested loops)') save_lbtop=wcd%lbtop - break2=wcode_cblock(wcd,cnode_arg(args,3),rv,new_ve) + save_shared_ve=wcd%shared_ve + wcd%shared_ve=ve + call wcode_comm_block(wcd,stmts,new_ve,rv,new_ve) if(.not.pm_is_compiling) then call wc_call(wcd,callnode,op_par_loop_end,0,1,0,ve) call set_jump_to_here(wcd,j) else call comp_finish_block(wcd,j) endif - wcd%ltop=wcd%ltop-1 - if(wcd%xbase>save_xbase) call release_import_varg(save_top) + wcd%shared_ve=save_shared_ve + wcd%lbtop=save_lbtop wcd%xbase=save_xbase wcd%top=save_top - wcd%lbtop=save_lbtop - end subroutine for_body + end subroutine pm_for subroutine any_statement logical:: any_break @@ -1879,9 +1663,66 @@ subroutine any_statement any_break=any_break.or.wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) if(.not.pm_is_compiling) call set_jump_to_here(wcd,jmp) enddo - call release_var(wcd,new_ve) + if(.not.pm_is_compiling) call release_var(wcd,new_ve) end subroutine any_statement + subroutine each_index_statement + logical:: any_break + integer:: k,kk,n,num_named,first_pc + integer,dimension(:),allocatable::rets + logical:: break + type(pm_ptr):: cblock,p + v=cnode_arg(args,nret+3) + v=cnode_arg(v,1) + slot=v%data%i(v%offset) + slot2=v%data%i(v%offset+1_pm_p) + u=pm_dict_val(wcd%context,wcd%sig_cache,int(& + rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) + cblock=cnode_arg(args,nret+2) + n=cnode_numargs(u) + if(nret>1) allocate(rets(n)) + do kk=1,n + arg=cnode_arg(u,kk) + rv%data%i(rv%offset+slot:rv%offset+slot2)=& + arg%data%i(arg%offset:arg%offset+slot2-slot) + + first_pc=wcd%pc + num_named=wcode_mvars(wcd,cblock,rv,ve) + + if(.not.pm_is_compiling) then + call wc_call(wcd,callnode,op_number,kk,2,1,ve) + call wc_arg(wcd,cnode_arg(args,nret),.true.,rv,ve) + endif + + p=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + break=wcode_call(wcd,p,rv,ve,.false.) + p=cnode_get(p,call_link) + enddo + + ! Close variables + if(.not.pm_is_compiling) then + call close_vars(wcd,cblock,rv,ve,first_pc,num_named) + endif + + if(nret>1) then + call wc_call(wcd,callnode,op_setref,0,3,1,ve) + rets(kk)=alloc_var(wcd,get_arg_type(wcd,cnode_arg(args,nret+4),rv)) + call wc(wcd,-rets(kk)) + call wc_arg(wcd,cnode_arg(args,nret+4),.false.,rv,ve) + endif + + enddo + if(nret>1) then + call wc_call(wcd,callnode,op_struct,get_var_type(wcd,cnode_arg(args,1),rv),n+2,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + do kk=1,n + call wc(wcd,rets(kk)) + call release_var(wcd,rets(kk)) + enddo + end if + end subroutine each_index_statement + function rvv(n) result(m) integer,intent(in):: n integer:: m @@ -1913,8 +1754,8 @@ end function call_flag_set ! nargs = number of args before arg... ! totargs = total number of args passed (including arg...) ! For comm calls only (for non-comm calls ve2==0) - ! ve = vector engine for outer scope - ! ve2 = vector engine for inner scope + ! ve = vector engine for inner scope + ! ve2 = vector engine for outer scope !==================================================================== recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& args,nargs,totargs,nkeys,nret,sig) @@ -1938,7 +1779,6 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif ignore_args=0 idx=rvv(cnode_get_num(callnode,call_index)) - ! Check for special signatures if(idx<0) then @@ -1946,19 +1786,15 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& case(sp_sig_dup) if(pm_is_compiling) then call comp_assign(wcd,callnode,& - cnode_arg(args,1),cnode_arg(args,2),.true.,rv,ve) - else - call wc_call_args(wcd,callnode,args,op_clone,0,2,1,rv,ve) - endif - case(sp_sig_thru) - if(pm_is_compiling) then - call comp_alias(wcd,callnode,cnode_arg(args,1),cnode_arg(args,2),& - rv,ve) + cnode_arg(args,1),cnode_arg(args,3+extra_ve*(num_comm_args-1)),.true.,rv,ve) else - call link_to_val(wcd,callnode,cnode_arg(args,1),& - wcd%base,cnode_arg(args,2),wcd%base,& - rv,ve) + call wc_call(wcd,callnode,op_clone,66,3,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + call wc_arg(wcd,cnode_arg(args,3+extra_ve*(num_comm_args-1)),.false.,rv,ve) endif + case(sp_sig_link) + call link_to_val(wcd,callnode,cnode_arg(args,3+extra_ve*(num_comm_args-1)),& + wcd%base,cnode_arg(args,1),wcd%base,rv,ve) case(sp_sig_noop) continue case(sp_sig_setval) @@ -1966,7 +1802,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& call wc_call(wcd,callnode,op_setref,0,3,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) call wc(wcd,& - -pm_max_stack-add_const(wcd,pm_type_val(wcd%context,check_arg_type(wcd,args,rv,1)))) + -pm_max_stack-& + add_const(wcd,pm_type_val(wcd%context,check_arg_type(wcd,args,rv,1)))) endif case default call wcode_error(wcd,callnode,'System Error!') @@ -2017,10 +1854,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& taints=cnode_get_num(procnode,node_args+2) if(wcd%inline_all.or.(wcd%proc_can_inline& .and.inlinable(procnode,args,nargs,nret,extra_ve))) then - ve1=preamble(ve1) call wcode_inlined_call(wcd,callnode,rv,ve1,ve2,args,nargs,& totargs,nret,taints,procnode,varg,conv) - call postamble wcd%inline_all=save_inline_all return else @@ -2052,7 +1887,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& op2=p%data%ln(p%offset)+1 endif else - op2=check_arg_type(wcd,args,rv,2) + op2=check_arg_type(wcd,args,rv,1) endif endif if(pm_is_compiling) then @@ -2061,7 +1896,6 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& if(comp_transform_op(wcd,callnode,op,op2,args,nargs,totargs,nret,rv,ve,ve2,extra_ve,conv)) return endif if(extra_ve>0) then - ve1=ve2 ignore_args=num_comm_args extra_ve=0 else @@ -2073,10 +1907,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& !write(*,*) 'CALLVE> PRE',ve1 - ve1=preamble(ve1) - if(pm_is_compiling.and.extra_ve>0) then - ve1=ve2 extra_ve=0 endif @@ -2166,8 +1997,6 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& if(pm_is_compiling) then call wc_correct_call_args(wcd) endif - - call postamble contains @@ -2195,28 +2024,14 @@ subroutine autoconv ! Argument indices are coded as displacements back from end of args ! (gets around possible presence of keyword args) idx=arg%data%i(arg%offset) - if(pm_fast_esize(arg)==1) then - tno=arg%data%i(arg%offset+1) - slot=alloc_var(wcd,tno) - call wc_call(wcd,callnode,op_make_poly,tno,3,1,ve) - call wc(wcd,-slot) - if(idx<0) then - call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) - else - call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) - endif + tno=arg%data%i(arg%offset+1) + slot=alloc_var(wcd,tno) + call wc_call(wcd,callnode,op_make_poly,tno,3,1,ve) + call wc(wcd,-slot) + if(idx<0) then + call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) else - if(idx<0) then - slot=get_sub_elem(wcd,callnode,op_elem,cnode_arg(keys,-idx),& - arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) - elseif(idx<=nargs) then - slot=get_sub_elem(wcd,callnode,op_elem,cnode_arg(args,idx),& - arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) - else - slot=get_sub_elem_from_slot(wcd,callnode,op_elem,& - wcd%rdata(wcd%xbase+idx-nargs),& - arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) - endif + call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) endif conv(idx)=slot enddo @@ -2241,11 +2056,8 @@ function add_proc(sig,ve2,extra_ve) result(n) proc=pm_dict_val(wcd%context,wcd%sig_cache,int(sig,pm_ln)) proc=cnode_arg(proc,1) if(cnode_get_kind(proc)==cnode_is_proc) then - if(cnode_flags_clear(proc,pr_flags,proc_run_complete).and.& - cnode_flags_clear(callnode,call_flags,proc_run_complete)) then - key(2)=1 - m=2 - endif + key(2)=1 + m=2 endif ! If not passing conditional context then zero extra_ve if(m==1) extra_ve=0 @@ -2288,13 +2100,6 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) !!$ ! Cannot currently inline procs with keyword args p=cnode_arg(proc,1) - ! For now cannot inline shared calls - flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proc_run_shared+proc_run_local) - if(flags/=0) then - ok=.false. - return - endif - ! Forced inline/no-inline in some contexts if(wcd%inline_none) then @@ -2335,84 +2140,6 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) end function inlinable - ! Preamble dealing with <> and <>/<>/<> - function preamble(ve) result(ve1) - integer,intent(in):: ve - integer:: ve1 - logical:: is_par,run_shared_or_local,run_shared - logical:: run_call_complete,run_proc_complete,run_complete,run_if_needed - integer:: opcode2 - is_par=par_kind<=par_mode_conc - run_shared_or_local=iand(taints,proc_run_shared+proc_run_local)/=0 - !.or..not.cnode_flags_clear(callnode,call_flags,proc_run_shared+proc_run_local) - run_shared=iand(taints,proc_run_shared)/=0 - !.or..not.cnode_flags_clear(callnode,call_flags,proc_run_shared) - run_call_complete=cnode_flags_set(callnode,call_flags,proc_run_complete) - run_proc_complete=iand(taints,proc_run_shared)/=0 - run_complete=run_proc_complete.or.run_call_complete - run_if_needed=(run_shared.or.run_complete.or.run_proc_complete).and.& - (iand(taints,proc_run_always)==0.and.& - cnode_flags_clear(callnode,call_flags,proc_run_always)) - enclosing_block=.false. - if(run_if_needed) then - ! opcode2==1 if need to check for live tasks across nodes - if(is_par.and.(run_shared.or.run_complete)) then - opcode2=1 - else - opcode2=0 - endif - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_skip_empty,opcode2,2,0,ve) - pc=comp_start_block(wcd) - enclosing_block=.true. - ve1=merge(shared_op_flag,0,run_shared_or_local) - else - ve1=alloc_var(wcd,pm_ve_type) - call wc_call(wcd,callnode,op_skip_empty,opcode2,3,0,merge(ve2,ve,ve2>=0)) - call wc(wcd,-ve1) - if(run_complete) then - call wc(wcd,ve) - else - call wc(wcd,wcd%lstack(wcd%ltop-1)) - endif - endif - elseif(run_shared_or_local) then - if(pm_is_compiling) then - ve1=shared_op_flag - else - ve1=wcd%lstack(wcd%ltop-1) - endif - elseif(run_complete) then - if(pm_is_compiling) then - ve1=0 - else - ve1=alloc_var(wcd,pm_ve_type) - call wc_simple_call(wcd,op_chan,0,2,ve) - call wc(wcd,-ve1) - endif - else - ve1=ve - endif - steps_back=is_par.and.iand(taints,proc_has_for)/=0.and.(& - iand(taints,proc_run_shared)/=0.or.& - cnode_flags_set(callnode,call_flags,proc_run_shared)) - if(steps_back) then - call wc_call(wcd,callnode,op_push_node_back,0,1,0,ve1) - endif - end function preamble - - ! Postamble dealing with <> and <> - subroutine postamble - if(steps_back) then - call wc_call(wcd,callnode,op_pop_off_node,0,1,0,ve1) - endif - if(pm_is_compiling) then - if(enclosing_block) then - call comp_finish_block(wcd,pc) - endif - endif - end subroutine postamble - ! Code keyword arguments (compling only) ! Each keyword comiled as pair of args: present/value subroutine comp_keys(nkeys) @@ -2449,24 +2176,18 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre logical,intent(in):: varg integer,dimension(totargs):: conv - integer:: save_base,save_oldbase,save_xbase,save_lbase,save_keybase,save_lbl + integer:: save_base,save_oldbase,save_xbase,save_keybase,save_lbl integer:: save_loop_extra_arg type(pm_ptr):: save_args,save_rv,save_keys,save_key_names - logical:: save_proc_is_chan,save_shared_inline type(pm_ptr):: pr,p,c,cblock,rv,arg,tv - integer:: pc,depth,par,num_named,first_pc,npar,slot,i,n,xarg,tno,lastxarg + integer:: pc,par,num_named,first_pc,npar,slot,i,n,xarg,tno,lastxarg,flags logical:: break integer:: ve integer:: nkeys - integer:: save_vevar + integer:: save_shared_ve - depth=cnode_get_num(callnode,call_par_depth) - if(depth/=0) depth=depth+wcd%lbase - if(depth0) wcd%rdata(wcd%top+1:wcd%top+pm_fast_esize(rv)+1)=-1 @@ -2566,7 +2281,6 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre enddo endif - wcd%lbase=wcd%ltop-1 wcd%oldbase=wcd%base wcd%base=wcd%top wcd%top=wcd%top+pm_fast_esize(rv)+1 @@ -2619,7 +2333,7 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre ! Process calls c=cnode_get(cblock,cblock_first_call) do while(.not.pm_fast_isnull(c)) - if(debug_wcode) write(*,*) 'INLINE> ve=',wcd%vevar + if(debug_wcode) write(*,*) 'INLINE> ve=',wcd%shared_ve break=wcode_call(wcd,c,rv,ve,.false.) c=cnode_get(c,call_link) enddo @@ -2637,7 +2351,6 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre wcd%top=wcd%base wcd%xbase=save_xbase - wcd%lbase=save_lbase wcd%base=save_base wcd%oldbase=save_oldbase wcd%outer_rv=save_rv @@ -2645,12 +2358,10 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre wcd%inline_keys=save_keys wcd%inline_key_names=save_key_names wcd%keybase=save_keybase - wcd%vevar=save_vevar - wcd%proc_is_chan=save_proc_is_chan + wcd%shared_ve=save_shared_ve wcd%lbtop=wcd%lbbase wcd%lbbase=save_lbl wcd%loop_extra_arg=save_loop_extra_arg - wcd%proc_shared_inline=save_shared_inline ! Close down parameters releasing vars if(.not.pm_is_compiling) then @@ -2952,15 +2663,14 @@ subroutine combine_labels(wcd,sig,start,finish,step,first_p,out_ve,& name2=cnode_arg(cnode_arg(args,1),1) if(name%offset/=name2%offset) then call mismatch(wcd,first_p,p,& - 'labels do not match: '//& + '"sync" labels do not match: '//& trim(pm_name_as_string(wcd%context,int(name%offset)))//' / '//& trim(pm_name_as_string(wcd%context,int(name2%offset)))) endif call wcode_comm_block(wcd,cnode_arg(args,2),out_ve,rv,ve) - case(sym_while,sym_each,sym_until,& - sym_while_invar,sym_until_invar,sym_foreach_invar) + case(sym_sync_while) call mismatch(wcd,first_p,p,& - 'labelled statement matched to communicating loop') + '"sync" statement matched to "sync while"') end select enddo @@ -3582,7 +3292,7 @@ subroutine wc_call(wcd,node,op,op2,nargs,nret,ve) integer,intent(in):: op2 integer,intent(in):: nargs,nret integer:: modl,line,last - integer:: depth + integer:: flags !write(*,*) 'wc_call',trim(op_names(op)),' nret=',nret if(.not.(pm_fast_isnull(wcd%inline_args).or.pm_is_compiling)) then modl=cnode_get_num(wcd%inline_args,cnode_modl_name) @@ -3619,22 +3329,25 @@ subroutine wc_call(wcd,node,op,op2,nargs,nret,ve) endif endif endif + + if(pm_debug_checks) then if(cnode_get_kind(node)/=cnode_is_call) then call pm_panic('wc call not callnode') endif endif - depth=cnode_get_num(node,call_par_depth)+wcd%lbase - !if(depth/=0) depth=depth+wcd%lbase - if(depth',wcd%rdata(slot1),var - wcd%rdata(slot1)=var - if(var<=0) return - if(arg_is_mvar(arg2)) then - wcd%ref_count(var-pm_stack_locals+1)=& - wcd%ref_count(var-pm_stack_locals+1)+1 + else + + slot1=cnode_get_num(arg1,var_index)+base1 + var=arg_slot_in_frame(wcd,arg2,base2) + if(debug_wcode) write(*,*) 'LINK>',wcd%rdata(slot1),var + wcd%rdata(slot1)=var + if(var<=0) return + if(arg_is_mvar(arg2)) then + wcd%ref_count(var-pm_stack_locals+1)=& + wcd%ref_count(var-pm_stack_locals+1)+1 + endif endif end subroutine link_to_val - + !==================================================================== ! Add a new constant to the current procedures constant pool !==================================================================== @@ -3935,10 +3649,10 @@ end function alloc_key_var !==================================================================== ! Allocate parameter variable !==================================================================== - function alloc_param_var(wcd,typ,isref,iskey,isshared,name) result(k) + function alloc_param_var(wcd,typ,isref,iskey,name) result(k) type(wcoder),intent(inout):: wcd integer,intent(in):: typ,name - logical,intent(in):: isref,iskey,isshared + logical,intent(in):: isref,iskey integer:: k integer:: flags !write(*,*) 'PARAM>>',trim(pm_type_as_string(wcd%context,typ)) @@ -3946,7 +3660,6 @@ function alloc_param_var(wcd,typ,isref,iskey,isshared,name) result(k) flags=v_is_param if(isref) flags=ior(flags,v_is_ref) if(iskey) flags=ior(flags,v_is_key) - if(isshared)flags=ior(flags,v_is_shared) k=cvar_alloc(wcd,typ,flags,name) else k=alloc_var(wcd,typ) @@ -4207,20 +3920,6 @@ function arg_is_mvar(arg) result(ok) endif end function arg_is_mvar - !==================================================================== - ! Argument does not exists in all tasks - ! (usually created in conditional context) - !==================================================================== - function arg_is_incomplete(arg) result(ok) - type(pm_ptr),intent(in):: arg - logical:: ok - ok=.false. - if(cnode_get_kind(arg)==cnode_is_var) then - if(.not.cnode_flags_clear(arg,var_flags,var_is_incomplete)) then - ok=.false. - endif - endif - end function arg_is_incomplete !==================================================================== ! Argument is variable created in a par statement @@ -4252,6 +3951,7 @@ subroutine wc(wcd,val) endif end subroutine wc + !==================================================================== ! Make more space for word-codes !==================================================================== @@ -4300,104 +4000,15 @@ subroutine wc_arg_get_elem(wcd,callnode,op,argout,argin,elem,rv,ve) aslot=arg_slot(wcd,argout) if(cvar_kind(wcd,aslot)/=v_is_ctime_const) then call comp_get_elem(wcd,op,& - aslot,arg_slot(wcd,argin),elem-1) + aslot,arg_slot(wcd,argin),elem) endif else - call wc_call(wcd,callnode,op,elem,3,1,ve) + call wc_call(wcd,callnode,op,merge(elem,elem+1,pm_is_compiling),3,1,ve) call wc_arg(wcd,argout,.true.,rv,ve) call wc_arg(wcd,argin,.false.,rv,ve) endif end subroutine wc_arg_get_elem - !==================================================================== - ! Gets sub-element .x.y.z of struct/rect argin, returning it in argout - !==================================================================== - subroutine wc_sub_elem(wcd,callnode,op,argout,argin,elems,start,end,rv,ve) - type(wcoder),intent(inout):: wcd - type(pm_ptr),intent(in):: callnode,argout,argin,rv - integer,dimension(*),intent(in):: elems - integer(pm_p),intent(in):: start, end - integer,intent(in):: op,ve - integer:: slot,out - if(pm_is_compiling) then - if(cvar_kind(wcd,var_slot(wcd,argout))==v_is_ctime_const) then - return - endif - endif - if(end-2=par_state_cond) then + call code_error(coder,node,& + '"'//trim(sym_names(sym))//'" cannot be used in this conditional context') + endif + endif + endif + coder%par_state=merge(par_state,par_state_none,issync.or.isinvar) + end function loop_par_state + !======================================================== ! switch statement - cases and otherwise clause ! assumes expression is in var @@ -930,13 +961,15 @@ subroutine trav_foreach_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node type(pm_ptr):: stmts,condition,iter,cblock2,amps - integer:: lex_scope,base,xtop + integer:: lex_scope,base,xtop,dtop,sym,call_sym amps=coder%iter_amps iter=node_arg(node,1) condition=node_arg(node,2) stmts=node_arg(node,4) + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop,dtop) + if(node_sym(condition)==sym_while) then lex_scope=push_lex_scope(coder) call trav_xexpr(coder,cblock,node,& @@ -947,12 +980,16 @@ subroutine trav_foreach_stmt(coder,cblock,pnode,node) cblock2=cblock endif + !!! coder%par_state + + if(base>=0) call hide_where_vars(coder,base+1,dtop) + if(pm_fast_isnull(condition)) then - call make_block_proc(coder,cblock2,node_arg(node,2),pm_null_obj,& + call make_block_proc(coder,cblock2,node_arg(node,1),pm_null_obj,& int(coder%iter_block_amps%offset),pm_null_obj,0,& stmts,iter,.true.,.false.) else - call make_block_proc(coder,cblock2,node_arg(node,2),pm_null_obj,& + call make_block_proc(coder,cblock2,node_arg(node,1),pm_null_obj,& int(coder%iter_block_amps%offset),& node_arg(condition,1),1,stmts,iter,.true.,.false.) endif @@ -961,16 +998,25 @@ subroutine trav_foreach_stmt(coder,cblock,pnode,node) call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) - call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop) - + if(base>=0) call reveal_vars(coder,base+1,dtop) + call make_iter_lists(coder,cblock2,iter,node_numargs(iter),.true.,.false.) call trav_expr(coder,cblock2,node,node_arg(iter,2)) call make_sys_call_rtn(coder,cblock2,node,sym_hash,1,1) - if(base>=0) call hide_vars(coder,base+1,xtop) + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + sym=node_sym(node) + if(sym==sym_foreach_invar) then + call_sym=sym_pm_foreach_invar_stmt + elseif(sym==sym_foreach_sync) then + call_sym=sym_pm_foreach_sync_stmt + else + call_sym=sym_pm_foreach_stmt + endif - call make_full_sys_call(coder,cblock2,node,sym_pm_foreach_stmt,6,0,amps,pm_null_obj,& + call make_full_sys_call(coder,cblock2,node,call_sym,6,0,amps,pm_null_obj,& pm_null_obj,proccall_is_comm+proccall_is_general) if(node_sym(condition)==sym_while) then @@ -997,7 +1043,7 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node type(pm_ptr):: stmts,iter,amps,keys,keynames - integer:: i,base,xtop + integer:: i,base,xtop,dtop amps=coder%iter_amps iter=node_arg(node,1) @@ -1009,6 +1055,9 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) keys=node_arg(keys,1) endif stmts=node_arg(node,4) + + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop,dtop) + if(base>=0) call hide_where_vars(coder,base+1,dtop) call make_block_proc(coder,cblock,node_arg(node,1),pm_null_obj,& int(coder%iter_block_amps%offset),pm_null_obj,0,stmts,iter,.true.,.true.) @@ -1017,7 +1066,7 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) - call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop) + if(base>=0) call reveal_vars(coder,base+1,dtop) call make_iter_lists(coder,cblock,iter,node_numargs(iter),.true.,.true.) @@ -1031,7 +1080,7 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) coder%temp2=keys ! protect from GC endif - if(base>=0) call hide_vars(coder,base+1,xtop) + if(base>=0) call hide_where_vars(coder,base+1,xtop) call make_full_sys_call(coder,cblock,node,& merge(sym_pm_for_stmt,sym_pm_forall_stmt,node_sym(node)==sym_for),& @@ -1043,6 +1092,88 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) include 'fisnull.inc' end subroutine trav_for_stmt + ! + !==================================================================== + subroutine trav_par_stmt(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: stmts,iter,amps,keys,keynames + integer:: i,base,xtop,dtop + + amps=coder%block_amp + keys=node_arg(node,1) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) + endif + stmts=node_arg(node,3) + + call trav_subexpr(coder,cblock,node,node_arg(node,2),base,xtop,dtop) + if(base>=0) call hide_where_vars(coder,base+1,dtop) + + call make_block_proc(coder,cblock,node,pm_null_obj,& + int(coder%comm_amp%offset),pm_null_obj,0,stmts) + + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + + if(base>=0) call reveal_vars(coder,base+1,dtop) + + call make_long_const(coder,cblock,node,int((node_numargs(node_arg(stmts,1))-1)/2,pm_ln)) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC + endif + + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + call make_full_sys_call(coder,cblock,node,& + sym_pm_par_stmt,4,0,amps,keys,keynames,& + proccall_is_comm+proccall_is_general) + + coder%temp2=pm_null_obj + + contains + include 'fisnull.inc' + end subroutine trav_par_stmt + + recursive subroutine trav_task(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: i,n,save_par_state + type(pm_ptr):: arg,cblock2 + n=node_numargs(node) + do i=2,n,2 + arg=node_arg(node,i) + call make_var(coder,cblock,arg,node_num_arg(arg,1),0) + call make_long_const(coder,cblock,arg,int(i/2,pm_ln)) + call make_sys_call(coder,cblock,arg,sym_clone,1,1) + enddo + call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) + save_par_state=coder%par_state + coder%par_state=par_state_par + do i=3,n,2 + arg=node_arg(node,i) + call make_temp_var(coder,cblock,node) + call dup_code(coder) + cblock2=make_cblock(coder,cblock,node,sym_task) + call swap_code(coder) + call make_long_const(coder,cblock2,arg,int((i-1)/2,pm_ln)) + call make_comm_sys_call(coder,cblock2,arg,sym_check_task,1,1) + call close_cblock(coder,cblock2) + call trav_stmt_list(coder,cblock,node,arg,sym_task) + enddo + coder%par_state=save_par_state + call make_sp_call(coder,cblock,node,sym_task,3*(n/2),0) + end subroutine trav_task + + !======================================================== ! Traverse "all" assignment !======================================================== @@ -1062,7 +1193,7 @@ recursive subroutine trav_all_stmt(coder,cblock,pnode,node) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,3)) call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3,0) - if(base>=0) call hide_vars(coder,base+1,xtop) + if(base>=0) call hide_where_vars(coder,base+1,xtop) end subroutine trav_all_stmt subroutine trav_ref(coder,cblock,pnode,node,islhs,call_sym) @@ -1236,7 +1367,7 @@ recursive subroutine trav_sync_stmt(coder,cblock,pnode,node) save_par_state=coder%par_state coder%par_state=par_state_sync call code_val(coder,node_arg(node,1)) - call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_sync) + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_sync,open_scope=.true.) call make_sp_call(coder,cblock,node,sym_sync,2,0) coder%par_state=save_par_state end subroutine trav_sync_stmt @@ -1299,7 +1430,7 @@ recursive subroutine trav_mode_stmt(coder,cblock,node,sym,call_sym) coder%temp2=keys ! protect from GC endif - if(base>=0) call hide_vars(coder,base+1,xtop) + if(base>=0) call hide_where_vars(coder,base+1,xtop) call make_block_proc(coder,cblock,node,& pm_null_obj,& @@ -1355,7 +1486,7 @@ recursive subroutine trav_over_stmt(coder,cblock,pnode,node) call trav_expr(coder,cblock,node,node_arg(node,1)) vbase=coder%vtop - if(base>=0) call hide_vars(coder,base+1,xtop) + if(base>=0) call hide_where_vars(coder,base+1,xtop) call make_block_proc(coder,cblock,node,& pm_null_obj,& @@ -2202,12 +2333,14 @@ end subroutine trav_xexpr !============================================================== ! Traverse extended expression: expr [check expr] { where ...} !============================================================== - recursive subroutine trav_subexpr(coder,cblock,exprp,exprn,base,top) + recursive subroutine trav_subexpr(coder,cblock,exprp,exprn,base,top,dtop) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,exprp,exprn integer,intent(out):: base,top - type(pm_ptr)::p,ass - integer:: i + integer,intent(out),optional:: dtop + type(pm_ptr)::p,ass,arg + integer:: i,j,wbase,name + logical:: ok p=exprn base=-1 top=-2 @@ -2223,18 +2356,33 @@ recursive subroutine trav_subexpr(coder,cblock,exprp,exprn,base,top) if(node_sym(p)/=sym_where) exit enddo top=coder%top + if(present(dtop)) dtop=coder%top endif - if(node_sym(p)==sym_distinct) then - do - do i=2,node_numargs(p),2 - call trav_comm_ref(coder,cblock,p,node_arg(p,i+1),.true.,.true.) - call dup_expr(coder,top_code(coder)) - call make_sys_call_rtn(coder,cblock,p,sym_get_val_ref,1,1) + if(node_sym(p)==sym_split) then + wbase=coder%wtop + do i=2,node_numargs(p),2 + arg=node_arg(p,i+1) + name=root_name(p) + ok=.true. + do j=wbase+1,coder%wtop + if(name==coder%wstack(i)) then + ok=.false. + exit + endif enddo - call make_sys_call(coder,cblock,p,sym_check_alias,node_numargs(p)/2,0) - p=node_arg(p,1) - if(node_sym(p)/=sym_distinct) exit + if(ok) call push_word(coder,name) + call trav_comm_ref(coder,cblock,p,arg,.true.,.true.) + call dup_expr(coder,top_code(coder)) + call make_var(coder,cblock,p,node_num_arg(p,i),var_is_where) + call make_sys_call_rtn(coder,cblock,p,sym_get_val_ref,1,1) + enddo + call make_sys_call(coder,cblock,p,sym_check_alias,node_numargs(p)/2,0) + do i=wbase+1,coder%wtop + call make_var(coder,cblock,p,coder%wstack(i),var_is_split+var_is_where) enddo + coder%wtop=wbase + p=node_arg(p,1) + top=coder%top endif if(node_sym(p)==sym_check) then call apply_x(p,node_arg(p,1)) @@ -2352,9 +2500,9 @@ subroutine code_check_invar(coder,cblock,node,val,sym) if(coder%par_state==par_state_none) then call code_error(coder,node,'Cannot have "'//trim(sym_names(sym))//'"'//& ' outside of a parallel context') - elseif(coder%par_state>=par_state_masked) then + elseif(coder%par_state>par_state_masked) then call code_error(coder,node,'Cannot have "'//trim(sym_names(sym))//'"'//& - ' inside a conditional statement within the parallel context') + ' inside this conditional context') endif endif call code_val(coder,val) @@ -2549,7 +2697,7 @@ subroutine trav_lhs(coder,cblock,node,lhs,rhs) enddo case(sym_where) do i=n,1,-1 - call make_definition(coder,cblock,lhs,node_arg(lhs,i),0) + call make_definition(coder,cblock,lhs,node_arg(lhs,i),var_is_where) enddo case(sym_assign) if(node_sym(rhs)==sym_assign) then @@ -2587,12 +2735,7 @@ subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) if(pm_fast_isnull(var)) then call make_definition(coder,cblock,node,lhs,0) else - if(iand(cnode_get_num(var,var_flags),& - var_is_var+var_is_not_inited)==var_is_not_inited) then - call make_split_definition(coder,cblock,node,var) - else - call make_assignment(coder,cblock,node,lhs,rhs,var) - endif + call make_assignment(coder,cblock,node,lhs,rhs,var) endif contains include 'fisname.inc' @@ -2703,27 +2846,24 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) if(present(avar)) then call trav_ref_to_var(coder,cblock,pnode,0,.true.,avar) call assign_call(pnode,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - cnode_flags_set(top_code(coder),var_flags,var_is_not_inited)) + cnode_flags_clear(top_code(coder),var_flags,var_is_ref)) elseif(node_sym(node)==sym_underscore) then call drop_code(coder) return elseif(pm_fast_isname(node)) then call trav_ref_to_var(coder,cblock,pnode,int(node%offset),.true.) call assign_call(pnode,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - cnode_flags_set(top_code(coder),var_flags,var_is_not_inited)) + cnode_flags_clear(top_code(coder),var_flags,var_is_ref)) else sym=node_sym(node) select case(sym) case(sym_reference) call trav_simple_ref(coder,cblock,pnode,node,.true.) - call assign_call(node,.false.,.false.) + call assign_call(node,.false.) case(sym_name) call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),.true.) call assign_call(node,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - cnode_flags_set(top_code(coder),var_flags,var_is_not_inited)) + cnode_flags_clear(top_code(coder),var_flags,var_is_ref)) case default !write(*,*) sym_names(sym) call code_error(coder,pnode,& @@ -2736,20 +2876,21 @@ recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) include 'fisnull.inc' include 'ftiny.inc' - subroutine assign_call(pnode,simple,undef) + subroutine assign_call(pnode,simple) type(pm_ptr),intent(in):: pnode - logical,intent(in):: simple,undef - if(simple.and.undef) then + logical,intent(in):: simple + integer:: call_sym + if(simple) then + call_sym=merge(sym_assign_or_init,sym_init_const,& + cnode_flags_set(top_code(coder),var_flags,var_is_var)) call dup_code(coder) call swap_code_2_1(coder) - call make_sys_call(coder,cblock,pnode,& - sym_assign_or_init,2,1,aflags=call_is_uninitialised) + call make_assign_call(coder,cblock,pnode,call_sym,2,1,& + aflags=call_takes_uninit+call_is_assign_call) else call swap_code(coder) call make_assign_call(coder,cblock,pnode,& - merge(sym_aliased_assign,& - merge(sym_assign_var,sym_assignment,simple),& - present(alias)),& + merge(sym_aliased_assign,sym_assignment,present(alias)),& 2,0,aflags=call_is_assign_call) endif end subroutine assign_call @@ -2787,6 +2928,7 @@ recursive subroutine make_definition(coder,cblock,node,vname,flags,vtype,mode) integer:: vcall,vflags logical:: has_mode + if(node_sym(vname)==sym_name.or.pm_fast_isname(vname)) then if(pm_fast_isname(vname)) then name=vname%offset @@ -2836,27 +2978,13 @@ recursive subroutine make_definition(coder,cblock,node,vname,flags,vtype,mode) call code_error(coder,node,& 'Left hand side of definition must be variable name') endif + contains include 'fisname.inc' include 'fvkind.inc' include 'fisnull.inc' include 'ftiny.inc' end subroutine make_definition - - !=================================================================== - ! Use expression on top of stack to initialise a constant - !=================================================================== - recursive subroutine make_split_definition(coder,cblock,node,var) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,var - call code_val(coder,var) - call make_sp_call(coder,cblock,node,sym_const,1,0) - call code_val(coder,var) - call swap_code(coder) - call make_sys_call(coder,cblock,node,sym_clone,& - 1,1) - call update_change_lists(coder,var,.true.) - end subroutine make_split_definition !======================================================== ! Reference to a variable @@ -2875,7 +3003,7 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) var=find_var_and_entry(coder,name,var_index) if(pm_fast_isnull(var)) then call code_error(coder,pnode,& - 'Variable has not been defined: ',name) + 'Variable or constant has not been defined: ',name) call make_temp_var(coder,cblock,pnode) return endif @@ -2884,7 +3012,7 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) if(islhs) then if(cnode_get_kind(var)==cnode_is_var) then flags=cnode_get_num(var,var_flags) - if(iand(flags,var_is_var)==0) then + if(iand(flags,var_is_var)==0.and..false.) then call code_error(coder,pnode,& 'Cannot assign to constant: ',name) else @@ -2894,6 +3022,10 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) call code_error(coder,pnode,& 'Cannot assign to constant: ',name) endif + else + if(cnode_get_kind(var)==cnode_is_var) then + call access_var(coder,var,.false.) + endif endif call code_val(coder,var) contains @@ -3108,7 +3240,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) logical:: save_fixed type(pm_ptr):: list,p,q integer:: loop_flags - + sym=node_sym(node) loop_flags=0 select case(sym) @@ -3201,6 +3333,13 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) enddo call make_sys_call_rtn(coder,cblock,node,& sym,n,1) + case(sym_as) + call trav_expr(coder,cblock,& + node,node_arg(node,1)) + call trav_expr(coder,cblock,& + node,node_arg(node,2)) + call make_sys_call_rtn(coder,cblock,node,& + sym,2,1,aflags=call_takes_uninit+call_converts_uninit) case(sym_pm_list) call make_temp_var(coder,cblock,node) call dup_code(coder) @@ -3332,6 +3471,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call dump_parse_tree(coder%context,6,node,2) call pm_panic('Code generator - unexpected node in expr') end select + contains include 'fisnull.inc' include 'fisname.inc' @@ -3416,19 +3556,7 @@ subroutine trav_name(coder,cblock,node,sym,name) call code_val(coder,p) endif else - p=find_var(coder,name) - if(pm_fast_isnull(p)) then - p=find_param(coder,cblock,node,name) - if(pm_fast_isnull(p)) then - call code_error(coder,node,& - 'Name not defined:',name) - call make_temp_var(coder,cblock,node) - else - call code_val(coder,p) - endif - else - call code_val(coder,p) - endif + call trav_ref_to_var(coder,cblock,p,name,.false.) endif contains @@ -4812,11 +4940,13 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) ! If debugging compiler, check tidy up if(pm_debug_checks) then if(coder%vtop/=obase-nret) then - write(*,*) coder%vtop,'/=',obase,'-',nret + write(*,*) coder%vtop,'/=',obase,'-',nret,& + trim(pm_name_as_string(coder%context,int(name%offset))) call pm_panic('trav_call vstack mismatch') endif if(coder%wtop/=owbase) then - write(*,*) coder%wtop,'/=',owbase + write(*,*) coder%wtop,'/=',owbase,& + trim(pm_name_as_string(coder%context,int(name%offset))) call pm_panic('trav_call wstack mismatch') endif !!$ if(coder%top/=otop) then @@ -5976,6 +6106,20 @@ subroutine hide_vars(coder,start,end) enddo end subroutine hide_vars + subroutine hide_where_vars(coder,start,end) + type(code_state),intent(inout):: coder + integer,intent(in):: start,end + integer:: i + do i=start,end + if(cnode_get_kind(coder%var(i))==cnode_is_var) then + if(cnode_flags_set(coder%var(i),var_flags,var_is_where)) then + coder%stack(i)=-coder%stack(i) + endif + endif + enddo + end subroutine hide_where_vars + + !==================================================== ! Undo hide_vars for block of variables !==================================================== @@ -5984,7 +6128,7 @@ subroutine reveal_vars(coder,start,end) integer,intent(in):: start,end integer:: i do i=start,end - coder%stack(i)=-coder%stack(i) + if(coder%stack(i)<0) coder%stack(i)=-coder%stack(i) enddo end subroutine reveal_vars @@ -6066,8 +6210,7 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) endif endif - if(cnode_get_name(cblocka,cblock_sym)==sym_sync.or.& - cnode_get_name(cblocka,cblock_sym)==sym_any) then + if(cnode_flags_set(cblocka,cblock_flags,cblock_is_open)) then cblock=cnode_get(cblocka,cblock_parent) else cblock=cblocka @@ -6078,7 +6221,7 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) call code_num(coder,name) ! Flag variables according to current par state - vflags=flags + vflags=merge(ior(var_is_par_var,flags),flags,coder%par_state==par_state_par) ! All named variables multi access (this may change) call code_num(coder,ior(vflags,var_is_multi_access)) @@ -6104,10 +6247,10 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) if(pm_fast_isnull(link)) then call pm_ptr_assign(coder%context,cblock,& int(cblock_first_var,pm_ln),& - top_code(coder)) + top_code(coder)) call pm_ptr_assign(coder%context,cblock,& int(cblock_last_var,pm_ln),& - top_code(coder)) + top_code(coder)) else call pm_ptr_assign(coder%context,link,int(var_link,pm_ln),& top_code(coder)) @@ -6628,9 +6771,15 @@ recursive subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,& subroutine update_arg(p) type(pm_ptr),intent(inout)::p -!!! Check for block import + if(pm_fast_vkind(p)==pm_pointer) then if(cnode_get_kind(p)==cnode_is_var) then + if(cnode_flags_set(p,var_flags,var_is_split)) then + call code_error(coder,p,& + 'Variable is used by an enclosing "distinct" clause and may not be used directly: ',& + cnode_get_num(p,var_name)) + call code_error(coder,p,'This is the "distinct" clause that splits this variable') + endif call update_change_lists(coder,p,.false.) !!$ if(.not.iscomm) then !!$ if(cnode_flags_set(p,var_flags,var_is_maybe_not_private)) then diff --git a/src/infer.f90 b/src/infer.f90 index 4f34fdb..28ad3ba 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -569,7 +569,8 @@ subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& do i=1,n call inf_cblock(coder,cnode_arg(arglist,i*2-1+n+n)) - dtype = pm_type_strip_literal(coder%context,get_arg_type(coder,callnode,cnode_arg(arglist,i*2+n+n))) + dtype = pm_type_strip_literal(coder%context,& + get_arg_type(coder,callnode,cnode_arg(arglist,i*2+n+n))) if(keytypes(i)>=0) then ptype=proc_keys%data%i(proc_keys%offset+i-1+n) @@ -887,7 +888,7 @@ subroutine inf_call(coder,cblock,callnode) ! Negative signatures indicate a control structure/special case ! call (with symbol sig) select case(sig) - case(sym_while) + case(sym_while,sym_while_invar,sym_while_sync) call check_loop_writes(4) list=cnode_arg(args,1) list2=cnode_arg(args,3) @@ -896,7 +897,7 @@ subroutine inf_call(coder,cblock,callnode) call clear_cblock_mark(list) call clear_cblock_mark(list2) call inf_cblock(coder,list) - call check_logical(2) + call check_logical(2,sig==sym_while_invar) if(arg_type(2)==coder%false_fix) return call inf_cblock(coder,list2) if(.not.(cblock_marked(list).or.& @@ -908,13 +909,8 @@ subroutine inf_call(coder,cblock,callnode) exit endif enddo - if(cblock_has_comm(cnode_arg(args,1))& - .or.cblock_has_comm(cnode_arg(args,3))) then - !!! call set_call_sig(merge(1,0,coder%par_kind2<=par_mode_conc)) - else - call set_call_sig(0) - endif - case(sym_until,sym_each) + if(sig/=sym_while) call mark_loop_cond(5) + case(sym_until,sym_until_invar,sym_until_sync,sym_each) call check_loop_writes(3) list=cnode_arg(args,1) counter=0 @@ -929,16 +925,17 @@ subroutine inf_call(coder,cblock,callnode) exit endif enddo - call check_logical(2) - if(cblock_has_comm(list)) then - !!! call set_call_sig(merge(1,0,coder%par_kind<=par_mode_conc)) - else - call set_call_sig(0) - endif + call check_logical(2,sig==sym_until_invar) + if(sig/=sym_until) call mark_loop_cond(5) case(sym_if,sym_if_invar) - call inf_if(count_updates(cnode_arg(args,4),2)) + call inf_if(count_updates(cnode_arg(args,4),2),sig==sym_if_invar) case(sym_pm_for,sym_pm_over) call inf_cblock(coder,cnode_arg(args,2)) + case(sym_task) + do i=1,nargs,3 + call inf_cblock(coder,cnode_arg(args,i+1)) + call inf_cblock(coder,cnode_arg(args,i+2)) + enddo case(sym_do,sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) call inf_cblock(coder,cnode_arg(args,1)) case(sym_sync) @@ -1234,7 +1231,7 @@ subroutine inf_call(coder,cblock,callnode) 'Check condition will always fail') endif elseif(tno/=coder%true_fix) then - call check_logical(3) + call check_logical(3,.false.) coder%stack(coder%base-2)=ior(coder%stack(coder%base-2),proc_is_impure) endif case(sym_fix,sym_literal) @@ -1347,12 +1344,13 @@ subroutine inf_call(coder,cblock,callnode) include 'ftiny.inc' include 'ftypeno.inc' - subroutine inf_if(nupdates) + subroutine inf_if(nupdates,isinvar) integer,intent(in):: nupdates + logical,intent(in):: isinvar integer,dimension(nupdates):: save_var_types integer:: i,tno,typ type(pm_ptr):: changelist,writelist,p,var - call check_logical(1) + call check_logical(1,isinvar) tno=arg_type(1) changelist=cnode_arg(args,4) writelist=cnode_arg(changelist,2) @@ -1642,24 +1640,46 @@ end function get_slot !================================================================== ! Check if argument m has logical type (bool in PM) !================================================================== - subroutine check_logical(m) + subroutine check_logical(m,isinvar) integer,intent(in):: m - integer:: slt - integer:: ty - integer:: i - type(pm_ptr):: tv - integer:: tno - tno=arg_type(m) + logical,intent(in):: isinvar + integer:: tno,mode + tno=arg_type_with_mode(m) if(tno/=error_type) then + tno=pm_type_strip_mode(coder%context,tno,mode) if(tno/=pm_logical.and.tno/=coder%true_literal.and.tno/=coder%false_literal.and.& tno/=coder%true_fix.and.tno/=coder%false_fix) then call inf_error_with_trace(coder,callnode,& 'Expecting boolean expression, got: '//& trim(pm_type_as_string(coder%context,tno))) endif + if(isinvar.and.mode/=sym_invar) then + call inf_error_with_trace(coder,callnode,& + 'Expecting "invar" expression, got: '//& + trim(sym_names(mode))) + endif endif end subroutine check_logical + + !================================================================== + ! Set loop call signature to 1 if it is in a conditional + ! (incling masked) context + !================================================================== + subroutine mark_loop_cond(m) + integer,intent(in):: m + integer:: tno,mark + tno=arg_type(m) + if(tno==pm_logical) then + mark=1 + elseif(cnode_flags_set(callnode,call_flags,call_is_cond)) then + mark=1 + else + mark=0 + endif + call set_call_sig(mark) + end subroutine mark_loop_cond + !================================================================== ! Check if argument m has long type (int type in PM) !================================================================== @@ -1887,7 +1907,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) do i=1,nargs tno=get_arg_type(coder,callnode,cnode_arg(args,i+nret),& - init=iand(flags,call_is_uninitialised)/=0) + init=flags) coder%wstack(coder%wtop+i)=tno undef_arg=undef_arg.or.tno<=0 enddo @@ -1938,7 +1958,6 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) if(amps/=0.and..not.ignore_rules) then amplocs=pm_name_val(coder%context,amps) do i=0,pm_fast_esize(amplocs) - write(*,*) 'AMPLOC-->',amplocs%data%i(amplocs%offset+i),i,pm_fast_esize(amplocs) tno2=pm_type_strip_mode(coder%context,& coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey),mode2) if(tno2>0) then @@ -3005,7 +3024,7 @@ end function add_poly_to_poly function get_arg_type(coder,callnode,arg,init) result(tno) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,arg - logical,intent(in),optional:: init + integer,intent(in),optional:: init integer:: tno if(cnode_get_kind(arg)==cnode_is_var) then tno=get_var_type(coder,callnode,arg,init) @@ -3019,13 +3038,16 @@ function get_arg_type(coder,callnode,arg,init) result(tno) endif end function get_arg_type - !================================================= + !============================================================================ ! Get currently resolved type (&mode) for variable - !================================================= + ! Can pass call flags through init parameter + ! - call_takes_init - no error for unitialised value + ! - call_converts_uninit - Convert uninitialsed value to a type value + !============================================================================ function get_var_type(coder,callnode,var,init) result(tno) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,var - logical,intent(in),optional:: init + integer,intent(in),optional:: init integer:: tno integer:: tk tno=coder%stack(cnode_get_num(var,var_index)+coder%base) @@ -3039,8 +3061,10 @@ function get_var_type(coder,callnode,var,init) result(tno) tk=pm_type_kind(coder%context,tno) if(tk==pm_type_is_uninitialised) then if(present(init)) then - if(init) then - tno=pm_type_arg(coder%context,tno,1) + if(iand(init,call_takes_uninit)/=0) then + if(iand(init,call_converts_uninit)/=0) then + tno=pm_type_arg(coder%context,tno,1) + endif return endif endif diff --git a/src/parser.f90 b/src/parser.f90 index ed82c41..444e8b8 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1630,7 +1630,7 @@ recursive function op(parser,sym,isconst,istype) result(iserr) logical:: iserr iserr=.true. select case(parser%sym) - case(first_operator:last_operator) + case(first_operator:last_operator,sym_as) sym=parser%sym call scan(parser) case(sym_open_square) @@ -2450,22 +2450,14 @@ recursive function valref(parser) result(iserr) integer:: n iserr=.true. n=0 - if(parser%sym==sym_caret) then + if(expect_name(parser)) return + if(parser%sym==sym_dcolon) then call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_caret,1) - else if(expect_name(parser)) return - if(parser%sym==sym_dcolon) then - call scan(parser) - if(expect_name(parser)) return - call make_node(parser,sym_use,2) - else - call make_node(parser,sym_name,1) - end if - endif + call make_node(parser,sym_use,2) + else + call make_node(parser,sym_name,1) + end if n=n+1 if(qual(parser)) return iserr=.false. @@ -2515,7 +2507,7 @@ function subexpr(parser) result(iserr) enddo call make_node(parser,sym_check,n) endif - do while(parser%sym==sym_distinct) + if(parser%sym==sym_split) then call scan(parser) m=0 do @@ -2529,8 +2521,8 @@ function subexpr(parser) result(iserr) exit endif enddo - call make_node(parser,sym_distinct,m+1) - end do + call make_node(parser,sym_split,m+1) + end if do while(parser%sym==sym_where) call scan(parser) m=0 @@ -2592,18 +2584,21 @@ end subroutine xexprlist recursive function while_stmt(parser) result(is_err) type(parse_state),intent(inout):: parser logical:: is_err - integer:: line,sym + integer:: line,pos,sym is_err=.true. - line=get_sym_line(parser) + call get_sym_pos(parser,line,pos) sym=sym_while call scan(parser) if(parser%sym==sym_invar) then sym=sym_while_invar call scan(parser) + elseif(parser%sym==sym_sync) then + sym=sym_while_sync + call scan(parser) endif call xexpr(parser) if(block_or_single_stmt(parser,sym_while,0,line)) return - call make_node(parser,sym,2) + call make_node_at(parser,sym,2,line,pos) is_err=.false. end function while_stmt @@ -2613,18 +2608,21 @@ end function while_stmt recursive function until_stmt(parser) result(is_err) type(parse_state),intent(inout):: parser logical:: is_err - integer:: line,sym + integer:: line,pos,sym is_err=.true. - line=get_sym_line(parser) + call get_sym_pos(parser,line,pos) sym=sym_until call scan(parser) if(parser%sym==sym_invar) then sym=sym_until_invar call scan(parser) + elseif(parser%sym==sym_sync) then + sym=sym_until_sync + call scan(parser) endif call xexpr(parser) if(block_or_single_stmt(parser,sym_until,0,line)) return - call make_node(parser,sym,2) + call make_node_at(parser,sym,2,line,pos) is_err=.false. end function until_stmt @@ -2634,13 +2632,13 @@ end function until_stmt recursive function do_stmt(parser) result(is_err) type(parse_state),intent(inout):: parser logical:: is_err - integer:: line,sym,lsym,n,base + integer:: line,pos,sym,lsym,n,base is_err=.true. - line=get_sym_line(parser) + call get_sym_pos(parser,line,pos) call scan(parser) if(parser%sym==sym_colon.or.parser%sym==sym_open_brace) then if(block_or_single_stmt(parser,sym_do,0,line)) return - call make_node(parser,sym_do_stmt,1) + call make_node_at(parser,sym_do_stmt,1,line,pos) else base=parser%top lsym=sym_list @@ -2711,7 +2709,9 @@ recursive function do_stmt(parser) result(is_err) endif if(close_block(parser,sym_do,0,line)) return endif - call make_node(parser,sym_do_stmt,5) + call push_null_val(parser) + if(subexpr(parser)) return + call make_node_at(parser,sym_do_stmt,6,line,pos) end if is_err=.false. end function do_stmt @@ -2731,6 +2731,9 @@ recursive function for_each_stmt(parser,name) result(is_err) if(parser%sym==sym_invar) then sym=sym_foreach_invar call scan(parser) + elseif(parser%sym==sym_sync) then + sym=sym_foreach_sync + call scan(parser) endif if(iter(parser,.false.,var_name)) return if(parser%sym==sym_while) then @@ -3068,13 +3071,16 @@ recursive function par_stmt(parser) result(is_error) else call push_null_val(parser) endif + call push_null_val(parser) + if(subexpr(parser)) return if(expect(parser,sym_open_brace)) return call stmt_list(parser) - k=2 + k=3 n=0 if(expect(parser,sym_task)) return do if(expect_name(parser)) return + call make_node(parser,sym_name,1) if(parser%sym==sym_open_attr) then call scan(parser) if(expect(parser,sym_work)) return @@ -3094,7 +3100,7 @@ recursive function par_stmt(parser) result(is_error) enddo if(close_block(parser,sym_par,0,line)) return if(has_work) then - do i=base+4,base+k,3 + do i=base+5,base+k,3 call push_val(parser,parser%vstack(i)) enddo call make_node(parser,sym_list,n) @@ -3132,11 +3138,14 @@ recursive function par_stmt(parser) result(is_error) endif call push_val(parser,parser%vstack(base+1)) call push_val(parser,parser%vstack(base+2)) - do i=3,k,3 + call push_val(parser,parser%vstack(base+3)) + do i=4,k,3 call push_val(parser,parser%vstack(base+i)) call push_val(parser,parser%vstack(base+i+2)) enddo - call make_node(parser,sym_par,2+n*2) + call make_node(parser,sym_task,n*2+1) + call make_node(parser,sym_list,1) + call make_node(parser,sym_par,3) k=parser%vtop parser%vtop=base+1 parser%vstack(parser%vtop)=parser%vstack(k) @@ -3296,9 +3305,11 @@ function sync_stmt(parser) result(iserr) iserr=.true. line=get_sym_line(parser) call scan(parser) - if(parser%sym==sym_while) then + if(parser%sym==sym_open) then call scan(parser) + if(expect(parser,sym_while)) return if(expect_and_get_name(parser,name)) return + if(expect(parser,sym_close)) return if(block_or_single_stmt(parser,sym_sync,name,line)) return call make_node(parser,sym_sync_while,2) else @@ -3398,9 +3409,6 @@ recursive subroutine stmt_list(parser,single) if(mode_stmt(parser)) goto 999 case(sym_dollar) if(proc_val_call()) goto 999 - case(sym_proceed) - call scan(parser) - call make_node(parser,sym_proceed,0) case(sym_sync) if(sync_stmt(parser)) goto 999 case(sym_return) @@ -4015,6 +4023,9 @@ recursive function typval(parser) result(iserr) if(opt_typ_list(parser,m)) return if(expect(parser,sym_close)) return call make_node(parser,sym_pm_dref,m+1) + case(sym_assign_or_init) + call make_node(parser,sym_assign_or_init,0) + call scan(parser) case(sym_dcaret) call scan(parser) if(parser%sym==sym_caret) then diff --git a/src/symbol.f90 b/src/symbol.f90 index b9b473f..3f614b7 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -119,48 +119,47 @@ module pm_symbol integer,parameter:: sym_ortho = first_key + 13 integer,parameter:: sym_is = first_key + 14 integer,parameter:: sym_is_not = first_key + 15 - integer,parameter:: sym_as = first_key + 16 - - ! Unary operators - integer,parameter:: sym_not = first_key + 17 + integer,parameter:: sym_not = first_key + 16 integer,parameter:: last_operator = sym_not ! Statement / expression general keywords - integer,parameter:: sym_null = last_operator + 1 - integer,parameter:: sym_true = last_operator + 2 - integer,parameter:: sym_false = last_operator + 3 - integer,parameter:: sym_struct = last_operator + 4 - integer,parameter:: sym_rec = last_operator + 5 - integer,parameter:: sym_any = last_operator + 6 - integer,parameter:: sym_present = last_operator + 7 - integer,parameter:: sym_unique = last_operator + 8 - integer,parameter:: sym_fix = last_operator + 9 - integer,parameter:: sym_new = last_operator + 10 - integer,parameter:: sym_when = last_operator + 11 + integer,parameter:: sym_as = last_operator+1 + integer,parameter:: sym_null = last_operator + 2 + integer,parameter:: sym_true = last_operator + 3 + integer,parameter:: sym_false = last_operator + 4 + integer,parameter:: sym_struct = last_operator + 5 + integer,parameter:: sym_rec = last_operator + 6 + integer,parameter:: sym_any = last_operator + 7 + integer,parameter:: sym_present = last_operator + 8 + integer,parameter:: sym_unique = last_operator + 9 + integer,parameter:: sym_fix = last_operator + 10 + integer,parameter:: sym_new = last_operator + 11 + integer,parameter:: sym_when = last_operator + 12 integer,parameter:: last_expr = sym_when integer,parameter:: last_word = last_expr ! Modes - integer,parameter:: sym_private = last_word + 1 - integer,parameter:: first_mode = sym_private - integer,parameter:: sym_joint = last_word + 2 - integer,parameter:: sym_uniform = last_word + 3 - integer,parameter:: sym_indep = last_word + 4 + integer,parameter:: sym_individual = last_word + 1 + integer,parameter:: first_mode = sym_individual + integer,parameter:: sym_connected = last_word + 2 + integer,parameter:: sym_constrained = last_word + 3 + integer,parameter:: sym_uniform = last_word + 4 - integer,parameter:: sym_chan = last_word + 5 - integer,parameter:: sym_nhd = last_word + 6 - integer,parameter:: sym_indexed = last_word + 7 - integer,parameter:: sym_local = last_word + 8 - - integer,parameter:: sym_invar = last_word + 9 - integer,parameter:: sym_shared = last_word + 10 - integer,parameter:: last_mode = sym_shared - integer,parameter:: last_key = sym_shared + integer,parameter:: sym_private = last_word + 5 + integer,parameter:: sym_chan = last_word + 6 + integer,parameter:: sym_nhd = last_word + 7 + integer,parameter:: sym_indexed = last_word + 8 + integer,parameter:: sym_joint = last_word + 9 + integer,parameter:: sym_invar = last_word + 10 + integer,parameter:: sym_shared = last_word + 11 + + integer,parameter:: last_mode = sym_shared + integer,parameter:: last_key = sym_shared ! Declaration keywords integer,parameter:: sym_package = last_key +1 + integer,parameter:: first_decl = sym_package integer,parameter:: sym_use = last_key + 2 - integer,parameter:: first_decl = sym_use integer,parameter:: sym_proc = last_key + 3 integer,parameter:: sym_param = last_key + 4 integer,parameter:: sym_type = last_key + 5 @@ -195,7 +194,7 @@ module pm_symbol integer,parameter:: sym_const = last_decl + 23 integer,parameter:: sym_each = last_decl + 24 integer,parameter:: sym_where = last_decl + 25 - integer,parameter:: sym_distinct = last_decl + 26 + integer,parameter:: sym_split = last_decl + 26 integer,parameter:: sym_forall = last_decl + 27 integer,parameter:: sym_interface = last_decl + 28 integer,parameter:: sym_if_invar = last_decl + 29 @@ -203,12 +202,13 @@ module pm_symbol integer,parameter:: sym_until_invar = last_decl + 31 integer,parameter:: sym_foreach_invar = last_decl + 32 integer,parameter:: sym_switch_invar = last_decl + 33 - integer,parameter:: sym_proceed= last_decl + 34 - integer,parameter:: sym_after= last_decl + 35 - integer,parameter:: sym_any_invar= last_decl + 36 - integer,parameter:: sym_all = last_decl + 37 - integer,parameter:: sym_sync_while = last_decl + 38 - integer,parameter:: last_resv = sym_sync_while + integer,parameter:: sym_any_invar= last_decl + 34 + integer,parameter:: sym_all = last_decl + 35 + integer,parameter:: sym_sync_while = last_decl + 36 + integer,parameter:: sym_while_sync = last_decl + 37 + integer,parameter:: sym_until_sync = last_decl + 38 + integer,parameter:: sym_foreach_sync = last_decl + 39 + integer,parameter:: last_resv = sym_foreach_sync ! Names used by internal system integer,parameter:: sym_pm_send = last_resv + 1 @@ -382,29 +382,32 @@ module pm_symbol integer,parameter:: sym_iter_args=hook + 36 integer,parameter:: sym_pm_foreach_stmt=hook + 37 integer,parameter:: sym_pm_foreach_invar_stmt=hook + 38 - integer,parameter:: sym_pm_for_stmt = hook + 39 - integer,parameter:: sym_pm_forall_stmt = hook + 40 - integer,parameter:: sym_pm_over_stmt = hook + 41 - integer,parameter:: sym_lhs_and_val = hook + 42 - integer,parameter:: sym_rhs_and_val = hook + 43 - integer,parameter:: sym_make_var= hook + 44 - integer,parameter:: sym_make_chan_var = hook + 45 - integer,parameter:: sym_make_nhd_var = hook + 46 - integer,parameter:: sym_make_lcl_var = hook + 47 - integer,parameter:: sym_make_invar_var = hook + 48 - integer,parameter:: sym_make_shared_var = hook + 49 - integer,parameter:: sym_make_const = hook + 50 - integer,parameter:: sym_chan_stmt = hook + 51 - integer,parameter:: sym_invar_stmt = hook + 52 - integer,parameter:: sym_shared_stmt = hook + 53 - integer,parameter:: sym_dechan = hook + 54 - integer,parameter:: sym_check_iter = hook + 55 - integer,parameter:: sym_check_iter_amp = hook + 56 - integer,parameter:: sym_check_iter_star = hook + 57 - integer,parameter:: sym_all_stmt = hook + 58 - integer,parameter:: sym_lhs_and_val_sync = hook + 59 - integer,parameter:: sym_iter_ref = hook + 60 - integer,parameter:: hook1 = hook + 60 + integer,parameter:: sym_pm_foreach_sync_stmt= hook + 39 + integer,parameter:: sym_pm_for_stmt = hook + 40 + integer,parameter:: sym_pm_forall_stmt = hook + 41 + integer,parameter:: sym_pm_over_stmt = hook + 42 + integer,parameter:: sym_pm_par_stmt = hook + 43 + integer,parameter:: sym_lhs_and_val = hook + 44 + integer,parameter:: sym_rhs_and_val = hook + 45 + integer,parameter:: sym_make_var= hook + 46 + integer,parameter:: sym_make_chan_var = hook + 47 + integer,parameter:: sym_make_nhd_var = hook + 48 + integer,parameter:: sym_make_lcl_var = hook + 49 + integer,parameter:: sym_make_invar_var = hook + 50 + integer,parameter:: sym_make_shared_var = hook + 51 + integer,parameter:: sym_make_const = hook + 52 + integer,parameter:: sym_chan_stmt = hook + 53 + integer,parameter:: sym_invar_stmt = hook + 54 + integer,parameter:: sym_shared_stmt = hook + 55 + integer,parameter:: sym_dechan = hook + 56 + integer,parameter:: sym_check_iter = hook + 57 + integer,parameter:: sym_check_iter_amp = hook + 58 + integer,parameter:: sym_check_iter_star = hook + 59 + integer,parameter:: sym_all_stmt = hook + 60 + integer,parameter:: sym_lhs_and_val_sync = hook + 61 + integer,parameter:: sym_iter_ref = hook + 62 + integer,parameter:: sym_check_task = hook + 63 + integer,parameter:: hook1 = hook + 63 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -520,7 +523,7 @@ module pm_symbol integer,parameter:: sym_split_param = hook5 + 32 integer,parameter:: sym_dim_noinit = hook5 + 33 integer,parameter:: sym_pm_node = hook5 + 34 - integer,parameter:: sym_init_var = hook5 + 35 + integer,parameter:: sym_init_const = hook5 + 35 integer,parameter:: sym_pm_dump = hook5 + 36 integer,parameter:: hook6 = 36 + hook5 @@ -624,15 +627,17 @@ module pm_symbol data sym_names(sym_fix) /'fix'/ data sym_names(sym_new) /'new'/ data sym_names(sym_when) /'when'/ + + data sym_names(sym_uniform) /'unif'/ + data sym_names(sym_individual) /'indiv'/ + data sym_names(sym_connected) /'cntd'/ + data sym_names(sym_constrained) /'cnstr'/ data sym_names(sym_private) /'priv'/ - data sym_names(sym_joint) /'jnt'/ - data sym_names(sym_uniform) /'unif'/ - data sym_names(sym_indep) /'indep'/ - data sym_names(sym_indexed) /'idx'/ data sym_names(sym_chan) /'chan'/ data sym_names(sym_nhd) /'nhd'/ - data sym_names(sym_local) /'lcl'/ + data sym_names(sym_indexed) /'idx'/ + data sym_names(sym_joint) /'jnt'/ data sym_names(sym_invar) /'invar'/ data sym_names(sym_shared) /'shrd'/ @@ -670,7 +675,7 @@ module pm_symbol data sym_names(sym_const) /'const'/ data sym_names(sym_each) /'foreach'/ data sym_names(sym_where) /'where'/ - data sym_names(sym_distinct) /'distinct'/ + data sym_names(sym_split) /'split'/ data sym_names(sym_forall) /'forall'/ data sym_names(sym_interface) /'interface'/ data sym_names(sym_switch_invar) /'switch invar'/ @@ -678,11 +683,12 @@ module pm_symbol data sym_names(sym_while_invar) /'while invar'/ data sym_names(sym_until_invar) /'until invar'/ data sym_names(sym_foreach_invar) /'foreach invar'/ - data sym_names(sym_proceed) /'proceed'/ - data sym_names(sym_after) /'after'/ data sym_names(sym_any_invar) /'any invar'/ data sym_names(sym_all) /'all'/ - data sym_names(sym_sync_while) /'sync while'/ + data sym_names(sym_sync_while) /'sync(while)'/ + data sym_names(sym_while_sync) /'while sync'/ + data sym_names(sym_until_sync) /'until sync'/ + data sym_names(sym_foreach_sync) /'foreach sync'/ data sym_names(sym_pm_send) /'PM__send'/ data sym_names(sym_pm_recv) /'PM__recv'/ @@ -847,9 +853,11 @@ module pm_symbol data sym_names(sym_iter_args) /'PM__iter_args'/ data sym_names(sym_pm_foreach_stmt) /'PM__foreach_stmt'/ data sym_names(sym_pm_foreach_invar_stmt) /'PM__foreach_invar_stmt'/ + data sym_names(sym_pm_foreach_sync_stmt) /'PM__foreach_sync_stmt'/ data sym_names(sym_pm_for_stmt) /'PM__for_stmt'/ data sym_names(sym_pm_forall_stmt) /'PM__forall_stmt'/ data sym_names(sym_pm_over_stmt) /'PM__over_stmt'/ + data sym_names(sym_pm_par_stmt) /'PM__par_stmt'/ data sym_names(sym_lhs_and_val) /'PM__lhs_and_val'/ data sym_names(sym_rhs_and_val) /'PM__rhs_and_val'/ data sym_names(sym_make_var) /'PM__make_var'/ @@ -872,6 +880,7 @@ module pm_symbol data sym_names(sym_all_stmt) /'PM__all_stmt'/ data sym_names(sym_lhs_and_val_sync) /'PM__lhs_and_val_sync'/ data sym_names(sym_iter_ref) /'PM__iter_ref'/ + data sym_names(sym_check_task) /'PM__check_task'/ data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ @@ -986,7 +995,7 @@ module pm_symbol data sym_names(sym_get_chunk) /'chunk'/ data sym_names(sym_pm_at) /'PM__at'/ data sym_names(sym_pm_node) /'PM__node'/ - data sym_names(sym_init_var) /'PM__init_var'/ + data sym_names(sym_init_const) /'PM__init_const'/ data sym_names(sym_infer_stack) /'infer_stack'/ data sym_names(sym_infer_type) /'infer_type'/ diff --git a/src/types.f90 b/src/types.f90 index bd39206..ed46e58 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -1049,7 +1049,7 @@ function pm_type_combine_modes(context,array,shared_ok) result(combined_mode) endif cmode=min(cmode,mode) enddo - if(cmode==sym_chan) cmode=sym_private + if(cmode==sym_chan.or.cmode==sym_nhd) cmode=sym_private combined_mode=cmode end function pm_type_combine_modes @@ -1068,12 +1068,10 @@ function pm_type_mix_modes(context,array) result(mixed_mode) cmin=min(cmin,mode) cmax=max(cmax,mode) enddo - if(cmin>sym_joint) then + if(cmin>=sym_joint) then mixed_mode=cmin elseif(cmax>=sym_joint) then mixed_mode=sym_joint - elseif(cmin==sym_local) then - mixed_mode=sym_local else mixed_mode=sym_private endif @@ -1085,6 +1083,20 @@ end function pm_type_mix_modes function pm_mode_includes(mode1,mode2) result(ok) integer,intent(in):: mode1,mode2 logical:: ok + if(mode1=sym_chan.and.mode2<=sym_joint + case(sym_individual) + ok=mode2=sym_invar + case default + call pm_panic('pm_mode_includes') + end select + endif ok=mode1==mode2 end function pm_mode_includes diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 4eb806d..d1197b6 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -945,7 +945,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif call release_var(wcd,new_ve) endif - case(sym_while) + case(sym_while,sym_while_invar,sym_while_sync) tno=check_arg_type(wcd,args,rv,2) if(tno==wcd%false_name) return if(restart) return @@ -983,7 +983,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call release_var(wcd,new_ve) endif - case(sym_until) + case(sym_until,sym_until_invar,sym_until_sync) if(restart) return if(cblock_has_comm(cnode_arg(args,1))) then break=.true. @@ -1252,6 +1252,10 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_chan,0,2,0,ve) call wc(wcd,-new_ve) + case(sym_task) + do i=3,nargs,3 + break2=wcode_cblock(wcd,cnode_arg(args,i),rv,ve) + enddo case(sym_any) call any_statement case(sym_pm_each_index) From ccea621d12e9c0681bfefb1606e64365592c67de Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Tue, 22 Apr 2025 21:03:11 +0100 Subject: [PATCH 13/36] Conditional context --- src/ast.f90 | 8 +-- src/codegen.f90 | 149 +++++++++++++++++++++++++++++++++++------------- src/infer.f90 | 49 ++++++++++------ src/parser.f90 | 91 +++++++++++++++++++++++------ src/symbol.f90 | 88 ++++++++++++++-------------- src/types.f90 | 24 +++++--- src/wcoder.f90 | 22 +++---- 7 files changed, 285 insertions(+), 146 deletions(-) diff --git a/src/ast.f90 b/src/ast.f90 index 9136148..0cfc4f9 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -115,10 +115,10 @@ module pm_ast integer,parameter:: proc_is_cond= 256 integer,parameter:: proc_is_uncond= 512 -!!$ integer,parameter:: proc_run_complete= 2**10 -!!$ integer,parameter:: proc_run_local= 2**11 -!!$ integer,parameter:: proc_run_shared= 2**12 -!!$ integer,parameter:: proc_run_always= 2**13 + integer,parameter:: proc_run_complete= 2**10 + integer,parameter:: proc_run_local= 2**11 + integer,parameter:: proc_run_shared= 2**12 + integer,parameter:: proc_run_always= 2**13 integer,parameter:: proc_is_open= 2**14 integer,parameter:: proc_is_abstract= 2**15 integer,parameter:: proc_is_generator = 2**16 diff --git a/src/codegen.f90 b/src/codegen.f90 index 0256595..8cd0c06 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -436,11 +436,11 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& merge(sym_if_invar,sym_if,sym==sym_switch_invar)) call drop_code(coder) coder%par_state=save_par_state - case(sym_while,sym_while_invar,sym_while_sync) + case(sym_while,sym_while_invar) lex_scope=push_lex_scope(coder) save_par_state=coder%par_state coder%par_state=loop_par_state(coder,node,& - sym,sym==sym_while_invar,sym==sym_while_sync) + sym,sym==sym_while_invar) cblock2=make_cblock(coder,cblock,node,sym_while) call trav_xexpr(coder,cblock2,node,node_arg(node,1)) call close_cblock(coder,cblock2) @@ -452,10 +452,10 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call make_sp_call(coder,cblock,node,sym,merge(4,5,sym==sym_while),0) call pop_lex_scope(coder) coder%par_state=save_par_state - case(sym_until,sym_until_invar,sym_until_sync) + case(sym_until,sym_until_invar) save_par_state=coder%par_state coder%par_state=loop_par_state(coder,node,sym,& - sym==sym_until_invar,sym==sym_until_sync) + sym==sym_until_invar) lex_scope=push_lex_scope(coder) cblock2=make_cblock(coder,cblock,node,sym_until) coder%lex_scope=lex_scope @@ -493,7 +493,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_mode_stmt(coder,cblock,node,sym,sym_chan_stmt) case(sym_for,sym_forall) call trav_for_stmt(coder,cblock,list,node) - case(sym_each,sym_foreach_invar,sym_foreach_sync) + case(sym_each,sym_foreach_invar) call trav_foreach_stmt(coder,cblock,list,node) case(sym_test) if(pm_fast_isnull(node_arg(node,1))) then @@ -738,34 +738,28 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& end subroutine trav_open_stmt_list - function loop_par_state(coder,node,sym,isinvar,issync) result(new_par_state) + function loop_par_state(coder,node,sym,isinvar) result(new_par_state) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: node integer,intent(in):: sym - logical,intent(in):: isinvar,issync + logical,intent(in):: isinvar integer:: new_par_state integer:: par_state par_state=coder%par_state if(par_state==par_state_none) then - if(isinvar.or.issync) then + if(isinvar) then call code_error(coder,node,& '"'//trim(sym_names(sym))//'" cannot be used outside of a parallel context') endif else - if(issync) then - if(par_state==par_state_cond.or.par_state==par_state_par) then - call code_error(coder,node,& - '"'//trim(sym_names(sym))//'" cannot be used in this conditional context'//& - ' without an enclosing "sync" statement') - endif - elseif(isinvar) then + if(isinvar) then if(par_state>=par_state_cond) then call code_error(coder,node,& '"'//trim(sym_names(sym))//'" cannot be used in this conditional context') endif endif endif - coder%par_state=merge(par_state,par_state_none,issync.or.isinvar) + coder%par_state=merge(par_state,par_state_none,isinvar) end function loop_par_state !======================================================== @@ -1010,8 +1004,6 @@ subroutine trav_foreach_stmt(coder,cblock,pnode,node) sym=node_sym(node) if(sym==sym_foreach_invar) then call_sym=sym_pm_foreach_invar_stmt - elseif(sym==sym_foreach_sync) then - call_sym=sym_pm_foreach_sync_stmt else call_sym=sym_pm_foreach_stmt endif @@ -1092,6 +1084,8 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) include 'fisnull.inc' end subroutine trav_for_stmt + + !==================================================================== ! !==================================================================== subroutine trav_par_stmt(coder,cblock,pnode,node) @@ -3624,6 +3618,8 @@ recursive subroutine trav_rec(coder,cblock,node) tno=pm_user_type_body(coder%context,top_word(coder)) call code_num(coder,pop_word(coder)) endif + call code_val(coder,coder%var(coder%mask)) + ! At this point tno contains the body of the rec type ! Match element names and push values in correct order @@ -3665,12 +3661,12 @@ recursive subroutine trav_rec(coder,cblock,node) ! Tidy up and create call if(pm_debug_checks) then - if(coder%vtop/=basex+n+2) then + if(coder%vtop/=basex+n+3) then write(*,*) '>>',coder%vtop,n,coder%vtop-n-2 call pm_panic('trav_rec') endif endif - call make_sp_call_rtn(coder,cblock,node,sym,n+2,1) + call make_sp_call_rtn(coder,cblock,node,sym,n+3,1) coder%vstack(vbase+1)=coder%vstack(coder%vtop) coder%vtop=vbase+1 @@ -5123,21 +5119,22 @@ recursive subroutine trav_proc(coder,node) npars=0 flags=node_get_num(node,proc_flags) pr_flags=flags - if(iand(flags,proccall_is_comm)/=0) then + if(iand(flags,proc_run_shared+proc_run_local+proc_run_complete)/=0) then + call code_params(cblock,.true.,argcall) + call export_params(cblock) + call code_keys(cblock,tkeys,keycall,.true.,.true.) + call code_special_check_body_and_result(cblock) + elseif(iand(flags,proccall_is_comm)/=0) then coder%par_state=par_state_comm_proc call code_params(cblock,.true.,argcall) - call code_keys(cblock,tkeys,keycall,.true.) - call code_loop_startup(cblock,cblock2) - call code_check(cblock2) - call code_body(cblock2) - call code_result(cblock2,flags) - call code_loop_finish(cblock,cblock2) + call code_keys(cblock,tkeys,keycall,.true.,.false.) + call code_loop_check_body_and_result(cblock) else coder%par_state=par_state_none call code_params(cblock,.false.,argcall) call make_state_vars(coder,cblock,node,& topo=coder%var(coder%proc_base+1)) - call code_keys(cblock,tkeys,keycall,.false.) + call code_keys(cblock,tkeys,keycall,.false.,.false.) call code_check(cblock) call code_body(cblock) call code_result(cblock,flags) @@ -5271,13 +5268,13 @@ subroutine code_params(cblock,iscomm,argcall) endif end subroutine code_params - recursive subroutine code_keys(cblock,tkeys,key_call,iscomm) + recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) type(pm_ptr),intent(in):: cblock type(pm_ptr),intent(inout):: key_call type(pm_ptr),intent(inout),target:: tkeys - logical,intent(in):: iscomm + logical,intent(in):: iscomm,isshrd type(pm_ptr):: p,typ,cblock2 - integer:: i,n,base,vname,vbase,wbase,tno,flags0 + integer:: i,n,base,newbase,vname,vbase,wbase,tno,flags0 flags0=merge(var_is_maybe_not_private,0,iscomm) @@ -5300,6 +5297,18 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm) flags0+var_is_param+var_is_key+var_is_multi_access) enddo + ! Export parameters for a gbl proc + if(isshrd) then + newbase=coder%top + do i=1,node_numargs(p)/3 + call make_var(coder,cblock,p,vname,& + flags0+var_is_param+var_is_key+var_is_multi_access+var_is_shadowed) + call code_val(coder,coder%var(base+i)) + call make_sys_call(coder,cblock,node,sym_export_param,1,1) + enddo + base=newbase + endif + ! Create a vector of all key names followed by all key types ! and finally by largest index associated with keys do i=1,node_numargs(p),3 @@ -5381,6 +5390,15 @@ recursive subroutine code_result(cblock,flags) if(.not.pm_fast_isnull(p)) then base=coder%vtop call trav_xexpr(coder,cblock,node,p) + if(iand(flags,proc_run_shared+proc_run_local)/=0) then + do i=coder%vtop+1-nret,coder%vtop + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call code_val(coder,coder%vstack(i)) + call make_comm_sys_call(coder,cblock,node,sym_import_param,1,1) + coder%vstack(i)=pop_code(coder) + enddo + end if call make_sp_call(coder,cblock,node,& sym_result,nret,0) rsig=pop_word(coder) @@ -5402,19 +5420,68 @@ recursive subroutine code_result(cblock,flags) endif end subroutine code_result - ! This sets up a par-loop structure for comm proc - subroutine code_loop_startup(cblock,cblock2) + subroutine code_special_check_body_and_result(cblock) type(pm_ptr),intent(in):: cblock - type(pm_ptr),intent(out):: cblock2 - call code_val(coder,coder%vstack(coder%state_base+4)) - cblock2=make_cblock(coder,cblock,node,sym_pct) - end subroutine code_loop_startup + type(pm_ptr):: cblock2 + integer:: sym + if(iand(flags,proc_run_shared+proc_run_local)/=0) then + sym=merge(sym_pm_shared_always,sym_pm_shared,iand(flags,proc_run_always)/=0) + else + sym=merge(sym_pm_chan_always,sym_pm_chan,iand(flags,proc_run_always)/=0) + endif + call code_val(coder,coder%var(coder%mask)) + cblock2=make_cblock(coder,cblock,node,sym) + call code_check(cblock2) + call code_body(cblock2) + call code_result(cblock2,flags) + call import_params(cblock2) + call close_cblock(coder,cblock2) + call make_sp_call(coder,cblock,node,sym,2,0) + end subroutine code_special_check_body_and_result + + subroutine export_params(cblock) + type(pm_ptr),intent(in):: cblock + integer:: i + type(pm_ptr):: var,p + p=node_get(node,proc_params) + call hide_vars(coder,coder%state_base+1,coder%state_base+num_comm_args) + do i=num_comm_args+1,npars + var=coder%var(coder%state_base+i) + call make_var(coder,cblock,p,cnode_get_num(var,var_name),& + ior(iand(cnode_get_num(var,var_flags),& + var_is_var+var_is_ref),var_is_shadowed)) + call code_val(coder,var) + call make_comm_sys_call(coder,cblock,p,sym_export_param,& + 1,1) + enddo + end subroutine export_params - subroutine code_loop_finish(cblock,cblock2) - type(pm_ptr),intent(in):: cblock,cblock2 + subroutine import_params(cblock) + type(pm_ptr),intent(in):: cblock + integer:: i,j + type(pm_ptr):: amp,p + p=node_get(node,proc_params) + amp=node_get(node,proc_amplocs) + do j=0,pm_fast_esize(amp) + i=amp%data%i(amp%offset+j) + call code_val(coder,coder%var(coder%state_base+i)) + call code_val(coder,coder%var(coder%state_base+npars-num_comm_args+i)) + call make_comm_sys_call(coder,cblock,p,sym_export_param,& + 1,1) + enddo + end subroutine import_params + + subroutine code_loop_check_body_and_result(cblock) + type(pm_ptr),intent(in):: cblock + type(pm_ptr):: cblock2 + call code_val(coder,coder%var(coder%state_base+4)) + cblock2=make_cblock(coder,cblock,node,sym_pct) + call code_check(cblock2) + call code_body(cblock2) + call code_result(cblock2,flags) call close_cblock(coder,cblock2) call make_sp_call(coder,cblock,node,sym_pct,2,0) - end subroutine code_loop_finish + end subroutine code_loop_check_body_and_result end subroutine trav_proc @@ -5744,6 +5811,8 @@ subroutine sort_sig(coder,sig,signo) endif if(cnode_get_num(proc1,pr_nret)/=cnode_get_num(proc2,pr_nret).or.& iand(cnode_get_num(proc1,pr_flags),proccall_is_comm+proc_is_cond)/=& + iand(cnode_get_num(proc2,pr_flags),proccall_is_comm+proc_is_cond).or.& + iand(cnode_get_num(proc1,pr_flags),proccall_is_comm+proc_is_uncond)/=& iand(cnode_get_num(proc2,pr_flags),proccall_is_comm+proc_is_cond)) then if(debug_more_codegen) write(*,*) 'SIG DIFFERENT' sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 diff --git a/src/infer.f90 b/src/infer.f90 index 28ad3ba..68f4e7a 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -622,7 +622,8 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) logical:: isstatic,iscomm if(debug_inference) then - write(*,*) 'BUILTIN>',trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) + write(*,*) 'BUILTIN>',& + trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) endif rtype=cnode_get_num(procnode,pr_rtype) @@ -888,7 +889,7 @@ subroutine inf_call(coder,cblock,callnode) ! Negative signatures indicate a control structure/special case ! call (with symbol sig) select case(sig) - case(sym_while,sym_while_invar,sym_while_sync) + case(sym_while,sym_while_invar) call check_loop_writes(4) list=cnode_arg(args,1) list2=cnode_arg(args,3) @@ -910,7 +911,7 @@ subroutine inf_call(coder,cblock,callnode) endif enddo if(sig/=sym_while) call mark_loop_cond(5) - case(sym_until,sym_until_invar,sym_until_sync,sym_each) + case(sym_until,sym_until_invar,sym_each) call check_loop_writes(3) list=cnode_arg(args,1) counter=0 @@ -1034,11 +1035,13 @@ subroutine inf_call(coder,cblock,callnode) name=t%data%i(t%offset+2) call push_word(coder,pm_type_new_rec+t%data%i(t%offset+4)) call push_word(coder,t%data%i(t%offset)) - do i=1,nargs-2 - call push_word(coder,arg_type_with_mode(i+3)) + do i=1,nargs-3 + call push_word(coder,arg_type_with_mode(i+4)) enddo mode=pm_type_combine_modes(coder%context,& - coder%wstack(coder%wtop-nargs+3:coder%wtop),.false.) + coder%wstack(coder%wtop-nargs+4:coder%wtop),& + cnode_flags_set(callnode,call_flags,call_is_cond).or.arg_type(4)==pm_logical,& + .false.) if(mode<0) then if(mode>-1000) then namep=pm_name_val(coder%context,pm_tv_name(t2)) @@ -1056,8 +1059,8 @@ subroutine inf_call(coder,cblock,callnode) endif mode=sym_invar endif - do i=1,nargs-2 - tno2=pm_type_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+2+i),mode2) + do i=1,nargs-3 + tno2=pm_type_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+3+i),mode2) tno3=pm_tv_arg(t2,i) if(tno2==pm_tiny_int) then tno2=tno3 @@ -1072,9 +1075,9 @@ subroutine inf_call(coder,cblock,callnode) '" needs to be initialised') endif endif - coder%wstack(coder%wtop-nargs+2+i)=tno2 + coder%wstack(coder%wtop-nargs+3+i)=tno2 enddo - call make_type_if_possible(coder,nargs) + call make_type_if_possible(coder,nargs-1) tno2=pop_word(coder) if(tno2>0) then if(.not.pm_type_includes(coder%context,tno,tno2,& @@ -1467,7 +1470,6 @@ subroutine inf_any(nupdates) endif end subroutine inf_any - subroutine inf_each_index() type(pm_ptr):: p,tv integer:: start,finish,tno,tno2,i,n,k,key(1) @@ -1912,11 +1914,17 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) undef_arg=undef_arg.or.tno<=0 enddo - if(is_comm.and.is_cond) then - coder%wstack(coder%wtop+num_comm_args)=pm_logical + if(is_comm) then + if(is_cond) then + coder%wstack(coder%wtop+num_comm_args)=pm_logical + else + if(coder%wstack(coder%wtop+num_comm_args)/=pm_logical) then + is_cond=.false. + endif + endif endif - ! Error return for error argument in + ! Error return for error argument if(undef_arg) then do i=1,nret call set_arg_to_error_type(i) @@ -1940,11 +1948,12 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) endif ! Suspend 'no shared import' rule in system module code - ignore_rules=ignore_rules.or.cnode_get_name(callnode,cnode_modl_name)==sym_pm_system + ignore_rules=ignore_rules.or.& + cnode_get_name(callnode,cnode_modl_name)==sym_pm_system ! Implement mode combination rule for standard procedures mode=pm_type_combine_modes(coder%context,& - coder%wstack(coder%wtop+1:coder%wtop+nargs),& + coder%wstack(coder%wtop+1:coder%wtop+nargs),is_cond,& ignore_rules) if(mode<0) then call call_error('Cannot pass a shared value to a standard procedure') @@ -2082,7 +2091,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass,nconsidered integer:: vbase,wbase type(pm_ptr):: tv,v,proc,match_proc,rtvect - integer:: rt,rt2,pars,mpars,apars,tno,match_pars + integer:: rt,rt2,pars,mpars,apars,tno,match_pars,pflags logical:: ok,found,visible,found_has_no_rtypes,when_no_match integer,dimension(1):: key integer:: memo @@ -2118,9 +2127,11 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) if(cnode_get_num(proc,pr_nret)/=nret) cycle if(cnode_get_num(proc,pr_amps)/=amps) cycle - if(iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general)/=& + pflags=cnode_get_num(proc,pr_flags) + if(iand(pflags,proccall_is_comm+proccall_is_ref+proccall_is_general)/=& iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general)) cycle - + if(iand(pflags,proc_is_cond)/=0.and..not.is_cond.or.& + iand(pflags,proc_is_uncond)/=0.and.is_cond) cycle nconsidered=nconsidered+1 pars=cnode_get_num(proc,pr_ptype) diff --git a/src/parser.f90 b/src/parser.f90 index 444e8b8..dd2d063 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1294,7 +1294,7 @@ recursive function arglist(parser,yield,dot) result(iserr) ! Call attributes but no arguments if(parser%sym==sym_open_attr) then - if(proc_call_attr(parser,.true.,flags)) return + if(call_attr(parser,.true.,flags)) return if(parser%sym/=sym_close) then if(expect(parser,sym_close)) return endif @@ -1408,7 +1408,7 @@ recursive function arglist(parser,yield,dot) result(iserr) ! Call attributes if present if(parser%sym==sym_open_attr) then - if(proc_call_attr(parser,.true.,flags)) return + if(call_attr(parser,.true.,flags)) return endif call push_num_val(parser,flags) @@ -1422,6 +1422,54 @@ recursive function arglist(parser,yield,dot) result(iserr) iserr=.false. end function arglist + !====================================================== + ! Procedure/call attributes + !====================================================== + recursive function call_attr(parser,iscall,flags) result(iserr) + type(parse_state),intent(inout):: parser + logical,intent(in):: iscall + integer,intent(inout):: flags + logical:: iserr + integer:: m + iserr=.true. + call scan(parser) + do + select case(parser%sym) + case(sym_inline) + call set_flags(proccall_is_inline) + call scan(parser) + case(sym_no_inline) + call set_flags(proccall_is_no_inline) + call scan(parser) + case(sym_ignore_rules) + call set_flags(call_ignore_rules) + call scan(parser) + case(sym_keep_literals) !!! IS THIS TO BE USED? + call set_flags(call_is_fixed) + call scan(parser) + end select + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + if(iand(flags,proccall_is_inline+proccall_is_no_inline)==& + proccall_is_inline+proccall_is_no_inline) then + call parse_error(parser,& + 'Cannot have both "<>" and "<>" attributes together') + endif + if(expect(parser,sym_close_attr)) return + iserr=.false. + contains + subroutine set_flags(new_flags) + integer,intent(in):: new_flags + if(iand(flags,new_flags)/=0) then + call parse_error(parser,& + 'Cannot repeat attribute "'//trim(sym_names(parser%sym))//'"') + endif + flags=ior(flags,new_flags) + end subroutine set_flags + end function call_attr + + !====================================================== ! Qualifiers ! .name [ ] @@ -2592,9 +2640,6 @@ recursive function while_stmt(parser) result(is_err) if(parser%sym==sym_invar) then sym=sym_while_invar call scan(parser) - elseif(parser%sym==sym_sync) then - sym=sym_while_sync - call scan(parser) endif call xexpr(parser) if(block_or_single_stmt(parser,sym_while,0,line)) return @@ -2616,9 +2661,6 @@ recursive function until_stmt(parser) result(is_err) if(parser%sym==sym_invar) then sym=sym_until_invar call scan(parser) - elseif(parser%sym==sym_sync) then - sym=sym_until_sync - call scan(parser) endif call xexpr(parser) if(block_or_single_stmt(parser,sym_until,0,line)) return @@ -2731,9 +2773,6 @@ recursive function for_each_stmt(parser,name) result(is_err) if(parser%sym==sym_invar) then sym=sym_foreach_invar call scan(parser) - elseif(parser%sym==sym_sync) then - sym=sym_foreach_sync - call scan(parser) endif if(iter(parser,.false.,var_name)) return if(parser%sym==sym_while) then @@ -4524,7 +4563,7 @@ end function param_list !====================================================== ! Procedure/call attributes !====================================================== - recursive function proc_call_attr(parser,iscall,flags) result(iserr) + recursive function proc_attr(parser,iscall,flags) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: iscall integer,intent(inout):: flags @@ -4540,11 +4579,8 @@ recursive function proc_call_attr(parser,iscall,flags) result(iserr) case(sym_no_inline) call set_flags(proccall_is_no_inline) call scan(parser) - case(sym_ignore_rules) - call set_flags(call_ignore_rules) - call scan(parser) - case(sym_keep_literals) - call set_flags(call_is_fixed) + case(sym_always) + call set_flags(proc_run_always) call scan(parser) end select if(parser%sym/=sym_comma) exit @@ -4566,7 +4602,7 @@ subroutine set_flags(new_flags) endif flags=ior(flags,new_flags) end subroutine set_flags - end function proc_call_attr + end function proc_attr !====================================================== ! Procedure declaration @@ -4675,10 +4711,27 @@ function proc_decl(parser) result(iserr) if(parser%sym==sym_yield) then if(yield_clause()) return endif + + if(parser%sym==sym_uncond) then + flags=ior(flags,proc_is_uncond) + elseif(parser%sym==sym_cond) then + flags=ior(flags,proc_is_cond) + endif + if(parser%sym==sym_global) then + flags=ior(flags,proc_run_shared) + elseif(parser%sym==sym_pm_shared) then + flags=ior(flags,proc_run_local) + elseif(parser%sym==sym_complete) then + if(iand(flags,proc_is_uncond)/=0) then + call parse_error(parser,'Cannot combine "cplt" and "uncond"') + endif + flags=ior(flags,proc_run_complete) + endif + ! Attributes if(parser%sym==sym_open_attr) then - if(proc_call_attr(parser,.false.,flags)) goto 999 + if(proc_attr(parser,.false.,flags)) goto 999 call push_null_val(parser) else call push_null_val(parser) diff --git a/src/symbol.f90 b/src/symbol.f90 index 3f614b7..e18aa5a 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -142,16 +142,18 @@ module pm_symbol integer,parameter:: sym_individual = last_word + 1 integer,parameter:: first_mode = sym_individual integer,parameter:: sym_connected = last_word + 2 - integer,parameter:: sym_constrained = last_word + 3 - integer,parameter:: sym_uniform = last_word + 4 - - integer,parameter:: sym_private = last_word + 5 - integer,parameter:: sym_chan = last_word + 6 - integer,parameter:: sym_nhd = last_word + 7 - integer,parameter:: sym_indexed = last_word + 8 - integer,parameter:: sym_joint = last_word + 9 - integer,parameter:: sym_invar = last_word + 10 - integer,parameter:: sym_shared = last_word + 11 + integer,parameter:: sym_local = last_word + 3 + integer,parameter:: sym_global = last_word + 4 + integer,parameter:: sym_complete = last_word + 5 + + integer,parameter:: sym_private = last_word + 6 + integer,parameter:: sym_chan = last_word + 7 + integer,parameter:: sym_nhd = last_word + 8 + integer,parameter:: sym_indexed = last_word + 9 + integer,parameter:: sym_joint = last_word + 10 + integer,parameter:: sym_uniform = last_word + 11 + integer,parameter:: sym_invar = last_word + 12 + integer,parameter:: sym_shared = last_word + 13 integer,parameter:: last_mode = sym_shared integer,parameter:: last_key = sym_shared @@ -205,10 +207,7 @@ module pm_symbol integer,parameter:: sym_any_invar= last_decl + 34 integer,parameter:: sym_all = last_decl + 35 integer,parameter:: sym_sync_while = last_decl + 36 - integer,parameter:: sym_while_sync = last_decl + 37 - integer,parameter:: sym_until_sync = last_decl + 38 - integer,parameter:: sym_foreach_sync = last_decl + 39 - integer,parameter:: last_resv = sym_foreach_sync + integer,parameter:: last_resv = sym_sync_while ! Names used by internal system integer,parameter:: sym_pm_send = last_resv + 1 @@ -382,32 +381,31 @@ module pm_symbol integer,parameter:: sym_iter_args=hook + 36 integer,parameter:: sym_pm_foreach_stmt=hook + 37 integer,parameter:: sym_pm_foreach_invar_stmt=hook + 38 - integer,parameter:: sym_pm_foreach_sync_stmt= hook + 39 - integer,parameter:: sym_pm_for_stmt = hook + 40 - integer,parameter:: sym_pm_forall_stmt = hook + 41 - integer,parameter:: sym_pm_over_stmt = hook + 42 - integer,parameter:: sym_pm_par_stmt = hook + 43 - integer,parameter:: sym_lhs_and_val = hook + 44 - integer,parameter:: sym_rhs_and_val = hook + 45 - integer,parameter:: sym_make_var= hook + 46 - integer,parameter:: sym_make_chan_var = hook + 47 - integer,parameter:: sym_make_nhd_var = hook + 48 - integer,parameter:: sym_make_lcl_var = hook + 49 - integer,parameter:: sym_make_invar_var = hook + 50 - integer,parameter:: sym_make_shared_var = hook + 51 - integer,parameter:: sym_make_const = hook + 52 - integer,parameter:: sym_chan_stmt = hook + 53 - integer,parameter:: sym_invar_stmt = hook + 54 - integer,parameter:: sym_shared_stmt = hook + 55 - integer,parameter:: sym_dechan = hook + 56 - integer,parameter:: sym_check_iter = hook + 57 - integer,parameter:: sym_check_iter_amp = hook + 58 - integer,parameter:: sym_check_iter_star = hook + 59 - integer,parameter:: sym_all_stmt = hook + 60 - integer,parameter:: sym_lhs_and_val_sync = hook + 61 - integer,parameter:: sym_iter_ref = hook + 62 - integer,parameter:: sym_check_task = hook + 63 - integer,parameter:: hook1 = hook + 63 + integer,parameter:: sym_pm_for_stmt = hook + 39 + integer,parameter:: sym_pm_forall_stmt = hook + 40 + integer,parameter:: sym_pm_over_stmt = hook + 41 + integer,parameter:: sym_pm_par_stmt = hook + 42 + integer,parameter:: sym_lhs_and_val = hook + 43 + integer,parameter:: sym_rhs_and_val = hook + 44 + integer,parameter:: sym_make_var= hook + 45 + integer,parameter:: sym_make_chan_var = hook + 46 + integer,parameter:: sym_make_nhd_var = hook + 47 + integer,parameter:: sym_make_lcl_var = hook + 48 + integer,parameter:: sym_make_invar_var = hook + 49 + integer,parameter:: sym_make_shared_var = hook + 50 + integer,parameter:: sym_make_const = hook + 51 + integer,parameter:: sym_chan_stmt = hook + 52 + integer,parameter:: sym_invar_stmt = hook + 53 + integer,parameter:: sym_shared_stmt = hook + 54 + integer,parameter:: sym_dechan = hook + 55 + integer,parameter:: sym_check_iter = hook + 56 + integer,parameter:: sym_check_iter_amp = hook + 57 + integer,parameter:: sym_check_iter_star = hook + 58 + integer,parameter:: sym_all_stmt = hook + 59 + integer,parameter:: sym_lhs_and_val_sync = hook + 60 + integer,parameter:: sym_iter_ref = hook + 61 + integer,parameter:: sym_check_task = hook + 62 + integer,parameter:: hook1 = hook + 62 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -628,16 +626,18 @@ module pm_symbol data sym_names(sym_new) /'new'/ data sym_names(sym_when) /'when'/ - data sym_names(sym_uniform) /'unif'/ data sym_names(sym_individual) /'indiv'/ data sym_names(sym_connected) /'cntd'/ - data sym_names(sym_constrained) /'cnstr'/ + data sym_names(sym_local) /'lcl'/ + data sym_names(sym_global) /'gbl'/ + data sym_names(sym_complete) /'cplt'/ data sym_names(sym_private) /'priv'/ data sym_names(sym_chan) /'chan'/ data sym_names(sym_nhd) /'nhd'/ data sym_names(sym_indexed) /'idx'/ data sym_names(sym_joint) /'jnt'/ + data sym_names(sym_uniform) /'unif'/ data sym_names(sym_invar) /'invar'/ data sym_names(sym_shared) /'shrd'/ @@ -686,9 +686,6 @@ module pm_symbol data sym_names(sym_any_invar) /'any invar'/ data sym_names(sym_all) /'all'/ data sym_names(sym_sync_while) /'sync(while)'/ - data sym_names(sym_while_sync) /'while sync'/ - data sym_names(sym_until_sync) /'until sync'/ - data sym_names(sym_foreach_sync) /'foreach sync'/ data sym_names(sym_pm_send) /'PM__send'/ data sym_names(sym_pm_recv) /'PM__recv'/ @@ -853,7 +850,6 @@ module pm_symbol data sym_names(sym_iter_args) /'PM__iter_args'/ data sym_names(sym_pm_foreach_stmt) /'PM__foreach_stmt'/ data sym_names(sym_pm_foreach_invar_stmt) /'PM__foreach_invar_stmt'/ - data sym_names(sym_pm_foreach_sync_stmt) /'PM__foreach_sync_stmt'/ data sym_names(sym_pm_for_stmt) /'PM__for_stmt'/ data sym_names(sym_pm_forall_stmt) /'PM__forall_stmt'/ data sym_names(sym_pm_over_stmt) /'PM__over_stmt'/ diff --git a/src/types.f90 b/src/types.f90 index ed46e58..3fa0d2a 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -1032,10 +1032,10 @@ end function pm_type_replace_mode ! Shared distributed value not allowed for position -combined_mode ! shared_ok -- permissible to have an argumnet with 'shared' mode !============================================================================================ - function pm_type_combine_modes(context,array,shared_ok) result(combined_mode) + function pm_type_combine_modes(context,array,is_cond,shared_ok) result(combined_mode) type(pm_context),pointer:: context integer,intent(in),dimension(:):: array - logical,intent(in):: shared_ok + logical,intent(in):: is_cond,shared_ok integer:: combined_mode integer:: i,mode,cmode,tno cmode=sym_invar @@ -1050,6 +1050,7 @@ function pm_type_combine_modes(context,array,shared_ok) result(combined_mode) cmode=min(cmode,mode) enddo if(cmode==sym_chan.or.cmode==sym_nhd) cmode=sym_private + if(is_cond.and.cmode==sym_invar) cmode=sym_uniform combined_mode=cmode end function pm_type_combine_modes @@ -1083,16 +1084,23 @@ end function pm_type_mix_modes function pm_mode_includes(mode1,mode2) result(ok) integer,intent(in):: mode1,mode2 logical:: ok - if(mode1=sym_private.and.mode2<=sym_invar + case(sym_global) + ok=mode2>=sym_invar + case(sym_complete) + ok=mode2>=sym_chan case(sym_connected) - ok=mode2>=sym_chan.and.mode2<=sym_joint + ok=mode2>sym_private.or.mode2==sym_global& + .or.mode2==sym_complete case(sym_individual) - ok=mode2=sym_private.and.mode2=sym_invar + ok=mode2==sym_uniform.or.mode2==sym_invar case default call pm_panic('pm_mode_includes') end select diff --git a/src/wcoder.f90 b/src/wcoder.f90 index d1197b6..e7d44aa 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -945,7 +945,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif call release_var(wcd,new_ve) endif - case(sym_while,sym_while_invar,sym_while_sync) + case(sym_while,sym_while_invar) tno=check_arg_type(wcd,args,rv,2) if(tno==wcd%false_name) return if(restart) return @@ -983,7 +983,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call release_var(wcd,new_ve) endif - case(sym_until,sym_until_invar,sym_until_sync) + case(sym_until,sym_until_invar) if(restart) return if(cblock_has_comm(cnode_arg(args,1))) then break=.true. @@ -1285,18 +1285,18 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) if(pm_is_compiling) then i=arg_slot(wcd,cnode_arg(args,1)) if(cvar_kind(wcd,i)==v_is_group) then - do kk=4,nargs + do kk=5,nargs call comp_alias(wcd,callnode,pm_null_obj,cnode_arg(args,kk),rv,ve,& - cvar_ptr(wcd,i,kk-3)) + cvar_ptr(wcd,i,kk-4)) enddo else typ=pm_type_strip_mode(wcd%context,get_arg_type(wcd,cnode_arg(args,1),rv),j) tv=pm_type_vect(wcd%context,typ) - do kk=4,nargs - if(pm_type_needs_storage(wcd%context,pm_tv_arg(tv,kk-3))) then + do kk=5,nargs + if(pm_type_needs_storage(wcd%context,pm_tv_arg(tv,kk-4))) then slot=arg_slot(wcd,cnode_arg(args,kk)) call comp_assign_slots(wcd,callnode,& - cvar_alloc_elem(wcd,i,kk-3),& + cvar_alloc_elem(wcd,i,kk-4),& slot,.true.,rv,ve) endif enddo @@ -1304,9 +1304,9 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) else typ=check_arg_type(wcd,args,rv,1) call wc_call(wcd,callnode,op_rec,& - typ,nargs-1,1,ve) + typ,nargs-2,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - do kk=4,nargs + do kk=5,nargs arg=cnode_arg(args,kk) call wc_arg(wcd,cnode_arg(args,kk),.false.,rv,ve) enddo @@ -1911,6 +1911,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& !write(*,*) 'CALLVE> PRE',ve1 + if(pm_is_compiling.and.extra_ve>0) then extra_ve=0 endif @@ -2001,6 +2002,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& if(pm_is_compiling) then call wc_correct_call_args(wcd) endif + contains @@ -2165,7 +2167,7 @@ subroutine comp_keys(nkeys) endif enddo end subroutine comp_keys - + end subroutine wcode_proc_call !==================================================================== From 230a7c744100e75b3f8dac9ff6c4e8bdbcbaafcf Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 25 Apr 2025 16:08:20 +0100 Subject: [PATCH 14/36] Merge literal values into symbol table --- src/array.f90 | 3 +- src/cnodes.f90 | 4 +- src/codegen.f90 | 78 ++++++++++++--------- src/infer.f90 | 23 +++--- src/parser.f90 | 182 ++++++++++++++++++------------------------------ src/symbol.f90 | 8 +-- src/types.f90 | 34 +++++---- src/vm.f90 | 2 +- src/wcoder.f90 | 14 ++-- 9 files changed, 170 insertions(+), 178 deletions(-) diff --git a/src/array.f90 b/src/array.f90 index 36ff734..e550949 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -1520,7 +1520,7 @@ function vector_export_if_needed(context,v,import_vec) result(w) if(vk==pm_tiny_int) then w=v else - w=pm_new(context,pm_logical,pm_fast_esize(import_vec)-3) + w=pm_new(context,pm_logical,max(1_pm_ln,pm_fast_esize(import_vec)-3)) if(vk==pm_null) then k=0 do i=4,pm_fast_esize(import_vec) @@ -1566,6 +1566,7 @@ function vector_export_if_needed(context,v,import_vec) result(w) enddo endif endif + contains include 'fvkind.inc' include 'fesize.inc' diff --git a/src/cnodes.f90 b/src/cnodes.f90 index dc3ce68..5481134 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -720,8 +720,10 @@ recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth, call append_to_line(iunit,str,i,'^',.false.,depth) endif case(cnode_is_const) + p=cnode_arg(cnode,1) + if(pm_fast_vkind(p)==pm_name) p=pm_name_val(context,int(p%offset)) call append_to_line(iunit,str,i,& - trim(pm_value_as_string(context,cnode_arg(cnode,1))),.false.,depth) + trim(pm_value_as_string(context,p)),.false.,depth) case(cnode_is_cblock) call append_to_line(iunit,str,i,'{',.true.,depth) call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,min(50,depth+2)) diff --git a/src/codegen.f90 b/src/codegen.f90 index 8cd0c06..74be96e 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -129,7 +129,7 @@ module pm_codegen ! Misc values type(pm_ptr):: temp,temp2,true,false,one,comm_amp type(pm_ptr):: std_amp,block_amp,iter_amps,iter_block_amps - type(pm_ptr):: check_mess,undef_val + type(pm_ptr):: undef_val ! 'true and 'false types integer:: true_fix,false_fix,true_literal,false_literal @@ -137,6 +137,9 @@ module pm_codegen ! '1 type integer:: unit_type + ! Check default error message + integer:: check_mess + ! Contextual information for this point in the traverse type(pm_ptr):: proc integer:: proc_base,proc_ncalls @@ -209,8 +212,7 @@ subroutine init_coder(context,coder,visibility) coder%std_amp,coder%block_amp,coder%iter_amps,& coder%iter_block_amps,array=coder%vstack,& array_size=coder%vtop) - coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check,& - coder%check_mess) + coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check) coder%sig_cache=pm_dict_new(context,32_pm_ln) coder%prog_cblock=pm_null_obj coder%defer_check=pm_null_obj @@ -253,7 +255,8 @@ subroutine init_coder(context,coder,visibility) pm_intern_val(coder%context,coder%iter_amps)) coder%iter_block_amps=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%iter_block_amps)) - coder%check_mess=pm_new_string(coder%context,'Failed "check" or "test""') + coder%check_mess=pm_new_literal_value_type(coder%context,& + pm_new_string(coder%context,'Failed "check" or "test""')) coder%proc_name_vals=pm_dict_new(coder%context,8_pm_ln) coder%id=0 coder%block_id=0 @@ -945,11 +948,7 @@ subroutine trav_pm_context(coder,cblock,pnode,node) end subroutine trav_pm_context !==================================================================== - ! Traverse a foreach statement node - ! - designed to be called indirectly by xexpr, which is used - ! to compute subexpressions covering iterators and attributes - ! - assumes variables from base to current top are 'where' variables - ! in the subexpression + ! Traverse foreach statement converting to a call to PM__foreach_stmt !==================================================================== subroutine trav_foreach_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder @@ -1026,10 +1025,7 @@ end subroutine trav_foreach_stmt !==================================================================== ! Traverse a for or forall statement node - ! - designed to be called indirectly by xexpr, which is used - ! to compute subexpressions covering iterators and attributes - ! - assumes variables from base to current top are 'where' variables - ! in the subexpression + ! converting to a call to PM__for_stmt / PM__forall_stmt !==================================================================== subroutine trav_for_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder @@ -2458,10 +2454,10 @@ recursive subroutine make_check(coder,cblock,p,base) do i=2,node_numargs(p),2 mess=node_arg(p,i) if(pm_fast_isnull(mess)) then - call make_const(coder,cblock,p,coder%check_mess) + call make_literal_const(coder,cblock,p,coder%check_mess) call code_null(coder) elseif(node_sym(mess)==sym_string) then - call make_const(coder,cblock,p,node_arg(mess,1)) + call make_literal_const(coder,cblock,p,node_num_arg(mess,1)) call code_null(coder) else call make_sys_var(coder,cblock,p,sym_check,var_is_shadowed) @@ -3453,11 +3449,9 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call make_sp_call_rtn(coder,cblock,node,sym_cast,2,1) case(sym_number,sym_string) if(coder%fixed) then - p=node_arg(node,1) - call make_const(coder,cblock,node,p,& - pm_new_fix_value_type(coder%context,p)) + call make_literal_const(coder,cblock,node,node_num_arg(node,1),fixit=.true.) else - call make_const(coder,cblock,node,node_arg(node,1)) + call make_literal_const(coder,cblock,node,node_num_arg(node,1)) endif case default call dump_parse_tree(coder%context,6,pnode,2) @@ -3652,7 +3646,7 @@ recursive subroutine trav_rec(coder,cblock,node) outer2:do i=1,m do j=1,n nam1=name1%data%i(name1%offset+i) - nam2=name2%data%i(name2%offset+j) + nam2=abs(name2%data%i(name2%offset+j)) if(nam1==nam2) cycle outer2 enddo call element_error(exprs,sym,name,name1,i) @@ -3843,7 +3837,8 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_false) call push_word(coder,coder%false_fix) case(sym_number,sym_string) - call push_word(coder,pm_new_fix_value_type(coder%context,node_arg(name,1))) + call push_word(coder,& + pm_fix_value_type_from_literal(coder%context,node_num_arg(name,1))) case default call push_word(coder,pm_type_new_fix) call push_word(coder,0) @@ -3858,7 +3853,7 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_false) call push_word(coder,coder%false_literal) case(sym_number,sym_string) - call push_word(coder,pm_new_literal_value_type(coder%context,name)) + call push_word(coder,node_num_arg(name,1)) case default call push_word(coder,pm_type_new_unfixed) call push_word(coder,0) @@ -5125,7 +5120,8 @@ recursive subroutine trav_proc(coder,node) call code_keys(cblock,tkeys,keycall,.true.,.true.) call code_special_check_body_and_result(cblock) elseif(iand(flags,proccall_is_comm)/=0) then - coder%par_state=par_state_comm_proc + coder%par_state=merge(par_state_comm_proc,par_state_none,& + iand(flags,proc_is_uncond)==0) call code_params(cblock,.true.,argcall) call code_keys(cblock,tkeys,keycall,.true.,.false.) call code_loop_check_body_and_result(cblock) @@ -5432,9 +5428,10 @@ subroutine code_special_check_body_and_result(cblock) call code_val(coder,coder%var(coder%mask)) cblock2=make_cblock(coder,cblock,node,sym) call code_check(cblock2) + coder%par_state=par_state_none call code_body(cblock2) - call code_result(cblock2,flags) call import_params(cblock2) + call code_result(cblock2,flags) call close_cblock(coder,cblock2) call make_sp_call(coder,cblock,node,sym,2,0) end subroutine code_special_check_body_and_result @@ -5462,13 +5459,15 @@ subroutine import_params(cblock) type(pm_ptr):: amp,p p=node_get(node,proc_params) amp=node_get(node,proc_amplocs) - do j=0,pm_fast_esize(amp) - i=amp%data%i(amp%offset+j) - call code_val(coder,coder%var(coder%state_base+i)) - call code_val(coder,coder%var(coder%state_base+npars-num_comm_args+i)) - call make_comm_sys_call(coder,cblock,p,sym_export_param,& - 1,1) - enddo + if(.not.pm_fast_isnull(amp)) then + amp=pm_name_val(coder%context,int(amp%offset)) + do j=0,pm_fast_esize(amp) + i=amp%data%i(amp%offset+j) + call code_val(coder,coder%var(coder%state_base+i)) + call code_val(coder,coder%var(coder%state_base+npars-num_comm_args+i)) + call make_comm_sys_call(coder,cblock,p,sym_import_param,2,0,assign=.true.) + enddo + endif end subroutine import_params subroutine code_loop_check_body_and_result(cblock) @@ -6460,6 +6459,23 @@ subroutine make_const(coder,cblock,node,val,typ) include 'ftypeof.inc' end subroutine make_const + !=========================================== + ! Make a constant from a literal type + !=========================================== + subroutine make_literal_const(coder,cblock,node,typ,fixit) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: typ + logical,intent(in),optional:: fixit + integer:: tno + tno=typ + if(present(fixit)) tno=pm_fix_value_type_from_literal(coder%context,tno) + call code_val(coder,pm_type_val(coder%context,tno)) + call code_num(coder,tno) + call make_code(coder,node,cnode_is_const,2) + end subroutine make_literal_const + + !=========================== ! Dupicate an expression !=========================== diff --git a/src/infer.f90 b/src/infer.f90 index 68f4e7a..5bce32c 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -740,6 +740,15 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) merge(sym_shared,sym_invar,& iand(pm_type_flags(coder%context,t1),pm_type_has_distributed)/=0)) endif + case(op_export_param) + t1=pm_type_strip_mode(coder%context,atype1,mode) + if(mode1) then - arg2=pm_dict_val(coder%context,coder%context%tcache,& - int(pm_tv_arg(tv,3),pm_ln)) + arg2=pm_type_val(coder%context,pm_tv_arg(tv,3)) endif rtyp=pm_type_strip_to_basic(coder%context,pm_type_arg(coder%context,rstype,1)) - !write(*,*) rtyp,'rtyp=',trim(pm_type_as_string(coder%context,rtyp)) - rtv=pm_type_vect(coder%context,rtyp) rtyp=pm_type_strip_to_basic(coder%context,pm_tv_arg(rtv,1)) if(rtyp==pm_long) then @@ -3398,6 +3403,8 @@ subroutine fold_string(coder,op,a,b,c) case(op_concat_fold) c=pm_concat_string(coder%context,a,b) end select + contains + include 'fname.inc' end subroutine fold_string !=============================================== diff --git a/src/parser.f90 b/src/parser.f90 index dd2d063..88cd6b6 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -59,8 +59,8 @@ module pm_parser integer:: ls,lineno,sym_lineno,name_lineno,old_sym_lineno logical:: newline,atstart integer:: n, sym_n, name_sym_n,old_sym_n, last, iunit - type(pm_ptr):: temp, lexval - integer:: sym, pushback + type(pm_ptr):: temp + integer:: sym, pushback, lexval integer,dimension(max_parse_stack):: stack integer:: top type(pm_ptr),dimension(max_parse_stack):: vstack @@ -105,7 +105,7 @@ subroutine init_parser(parser,context) parser%vtop=max_parse_stack parser%reg=>pm_register(context,'parser',& parser%modl,parser%modls,parser%modl_dict,& - parser%temp,parser%sysmodl,parser%lexval, & + parser%temp,parser%sysmodl, & parser%visibility,parser%op_names,& array=parser%vstack, & array_size=parser%vtop) @@ -596,7 +596,7 @@ subroutine scan(parser) val=pm_new_string(parser%context,buffer(1:n)) endif sym=sym_string - parser%lexval=val + parser%lexval=pm_new_literal_value_type(parser%context,val) case('''') if(peekchar()=='''') then sym=sym_caret @@ -670,6 +670,7 @@ subroutine scan(parser) include 'fnewnc.inc' include 'ftypeno.inc' + include 'fname.inc' ! Get next character from current line and advance function getchar() result(ch) @@ -869,77 +870,18 @@ subroutine numeric 'Numeric constant out of range') endif c=peekchar() - if(c=='''') then - c=getchar() - c=getchar() - select case(c) - case('s') - if(iscomplex) then - val=pm_fast_newnc(parser%context, & - pm_single_complex,1) - val%data%c(val%offset)=cmplx(0.0,rnumber) - elseif(isreal) then - val=pm_fast_newnc(parser%context, & - pm_single,1) - val%data%r(val%offset)=rnumber - else - val=pm_fast_newnc(parser%context, & - pm_int,1) - val%data%i(val%offset)=inumber - endif - case('l') - if(isreal) then - call parse_error(parser,'Long real not available') - else - val=pm_fast_newnc(parser%context, & - pm_longlong,1) - val%data%lln(val%offset)=inumber - endif - case('8') - if(isreal) goto 20 - if(isdigit(peekchar())) goto 20 - if(inumber<-127.or.inumber>127) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int8,1) - val%data%i8(val%offset)=inumber - case('1') - if(isreal) goto 20 - if(peekchar()/='6'.or.isdigit(peekchar_plus(1))) goto 20 - if(inumber<-16383.or.inumber>16383) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int16,1) - val%data%i16(val%offset)=inumber - c=getchar() - case('3') - if(isreal) goto 20 - if(peekchar()/='2'.or.isdigit(peekchar_plus(1))) goto 20 - if(inumber<-2147483647.or.inumber>2147483647) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int32,1) - val%data%i32(val%offset)=inumber - c=getchar() - case('6') - if(isreal) goto 20 - if(peekchar()/='4'.or.isdigit(peekchar_plus(1))) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int64,1) - val%data%i64(val%offset)=inumber - c=getchar() - end select + if(iscomplex) then + val=pm_fast_newnc(parser%context, & + pm_double_complex,1) + val%data%dc(val%offset)=cmplx(0.0,rnumber,kind=pm_d) + else if(isreal) then + val=pm_fast_newnc(parser%context,pm_double,1) + val%data%d(val%offset)=rnumber else - if(iscomplex) then - val=pm_fast_newnc(parser%context, & - pm_double_complex,1) - val%data%dc(val%offset)=cmplx(0.0,rnumber,kind=pm_d) - else if(isreal) then - val=pm_fast_newnc(parser%context,pm_double,1) - val%data%d(val%offset)=rnumber - else - val=pm_fast_newnc(parser%context,pm_long,1) - val%data%ln(val%offset)=inumber - endif + val=pm_fast_newnc(parser%context,pm_long,1) + val%data%ln(val%offset)=inumber endif - parser%lexval=val + parser%lexval=pm_new_literal_value_type(parser%context,val) sym=sym_number return 20 continue @@ -1527,6 +1469,7 @@ recursive function qual(parser,dot_call) result(iserr) if(expect(parser,sym_close)) return elseif(sym==sym_open) then call make_node(parser,sym_proc,1) + call scan(parser) if(exprlist(parser,sym=sym_pm_list)) return call make_node(parser,sym_open,2) if(expect(parser,sym_close)) return @@ -1863,7 +1806,7 @@ recursive function term(parser,checkqual) result(iserr) call make_node(parser,sym_present,1) if(expect(parser,sym_close)) return case(sym_number,sym_string) - call push_val(parser,parser%lexval) + call push_num_val(parser,parser%lexval) call make_node(parser,sym,1) call scan(parser) case(sym_dollar) @@ -4001,12 +3944,7 @@ recursive function typval(parser) result(iserr) if(parser%sym==sym_open) then call scan(parser) if(parser%sym==sym_number) then - if(pm_fast_vkind(parser%lexval)/=& - pm_long) then - call parse_error(parser,& - 'Cannot have "fix" before non-default integer constant') - endif - call push_val(parser,parser%lexval) + call push_num_val(parser,parser%lexval) call make_node(parser,sym_number,1) call scan(parser) call make_node(parser,sym,1) @@ -4015,7 +3953,7 @@ recursive function typval(parser) result(iserr) call scan(parser) call make_node(parser,sym,1) elseif(parser%sym==sym_string) then - call push_val(parser,parser%lexval) + call push_num_val(parser,parser%lexval) call make_node(parser,sym_string,1) call scan(parser) call make_node(parser,sym,1) @@ -4642,14 +4580,14 @@ function proc_decl(parser) result(iserr) iscomm=.true. isref=.true. endif - + ! Procedure name if(.not.check_name(parser,name)) then if(.not.isref) then if(op(parser,name,.false.,.false.)) goto 999 endif endif - + ! Communicating proc flags if(.not.isref) then if(parser%sym==sym_pct) then @@ -4665,7 +4603,7 @@ function proc_decl(parser) result(iserr) ! Start of parameters if(expect(parser,sym_open)) goto 999 - + 10 continue ! Create fully qualified (module!name) procedure name @@ -4707,26 +4645,35 @@ function proc_decl(parser) result(iserr) call push_null_val(parser) nret=-1 endif - + if(parser%sym==sym_yield) then if(yield_clause()) return endif - if(parser%sym==sym_uncond) then - flags=ior(flags,proc_is_uncond) - elseif(parser%sym==sym_cond) then - flags=ior(flags,proc_is_cond) - endif - - if(parser%sym==sym_global) then - flags=ior(flags,proc_run_shared) - elseif(parser%sym==sym_pm_shared) then - flags=ior(flags,proc_run_local) - elseif(parser%sym==sym_complete) then - if(iand(flags,proc_is_uncond)/=0) then - call parse_error(parser,'Cannot combine "cplt" and "uncond"') + if(iscomm) then + + if(parser%sym==sym_uncond) then + flags=ior(flags,proc_is_uncond) + call scan(parser) + elseif(parser%sym==sym_cond) then + flags=ior(flags,proc_is_cond) + call scan(parser) endif - flags=ior(flags,proc_run_complete) + + if(parser%sym==sym_global) then + flags=ior(flags,proc_run_shared) + call scan(parser) + elseif(parser%sym==sym_pm_shared) then + flags=ior(flags,proc_run_local) + call scan(parser) + elseif(parser%sym==sym_complete) then + if(iand(flags,proc_is_uncond)/=0) then + call parse_error(parser,'Cannot combine "cplt" and "uncond"') + endif + flags=ior(flags,proc_run_complete) + call scan(parser) + endif + endif ! Attributes @@ -4741,14 +4688,14 @@ function proc_decl(parser) result(iserr) if(parser%sym==sym_dotdotdot) then call scan(parser) flags=ior(flags,proc_is_open) - endif - + endif + ! = expr or [ check expr ] block if(parser%sym==sym_assign.and.nret==-1) then - + call push_null_val(parser) call scan(parser) - + m=0 do if(isref) then @@ -4826,22 +4773,22 @@ function proc_decl(parser) result(iserr) endif call push_null_val(parser) ! Code tree - + if(parser%error_count>scount) then parser%vtop=sbase goto 999 endif if(parser%error_count>0) goto 999 - + ! Assign flags to proc_flags slot parser%vstack(parser%vtop-& proc_num_args-node_args+proc_flags+1)%offset=flags - + ! Assign number of returns to proc_numret slot parser%vstack(parser%vtop-& proc_num_args-node_args+proc_numret+1)%offset=nret - + if(pm_debug_checks) then if(parser%vtop-base/=proc_num_args) then write(*,*) '=========',parser%vtop-base,proc_num_args @@ -4856,7 +4803,7 @@ function proc_decl(parser) result(iserr) endif call make_node_at(parser,sym,proc_num_args,line,pos) - + if(debug_parser) then write(*,*) 'PROC DECL>----------------' call dump_parse_tree(parser%context,44,top_val(parser),2) @@ -4864,7 +4811,7 @@ function proc_decl(parser) result(iserr) endif call add_proc_decl(parser,name,ptr) - + iserr=.false. 999 continue call pm_delete_register(parser%context,reg) @@ -4925,14 +4872,14 @@ function yield_clause() result(iserr) call make_node(parser,node_sym(params),n*2+num_comm_args) parser%vstack(parser%vtop-8)=top_val(parser) call drop_val(parser) - + call name_vector(parser,base) parser%vstack(parser%vtop-6)=top_val(parser) call drop_val(parser) - + iserr=.false. end function yield_clause - + function return_stmt() result(iserr) logical:: iserr integer:: m @@ -4975,7 +4922,7 @@ function return_stmt() result(iserr) parser%vtop=parser%vtop-1 iserr=.false. end function return_stmt - + end function proc_decl !====================================================== @@ -5273,10 +5220,12 @@ function intrinsic(parser) result(iserr) if(expect(parser,sym_colon)) goto 999 if(expect(parser,sym_string)) goto 999 - p=pm_dict_lookup(parser%context,parser%op_names,parser%lexval) + p=pm_dict_lookup(parser%context,parser%op_names,& + pm_type_val(parser%context,& + parser%lexval)) if(pm_fast_isnull(p)) then call parse_error(parser,'Bad intrinsic operation'//& - pm_value_as_string(parser%context,parser%lexval)) + pm_value_as_string(parser%context,pm_type_val(parser%context,parser%lexval))) goto 999 endif opcode=p%offset @@ -5284,7 +5233,8 @@ function intrinsic(parser) result(iserr) if(parser%sym==sym_open) then call scan(parser) if(expect(parser,sym_number)) goto 999 - opcode2=parser%lexval%data%ln(parser%lexval%offset) + p=pm_type_val(parser%context,parser%lexval) + opcode2=p%data%ln(p%offset) if(expect(parser,sym_close)) goto 999 elseif(parser%sym>=first_mode.and.parser%sym<=last_mode) then opcode2=parser%sym diff --git a/src/symbol.f90 b/src/symbol.f90 index e18aa5a..472170e 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -786,7 +786,7 @@ module pm_symbol data sym_names(sym_local_sub) /''/ data sym_names(sym_set_mode) /''/ data sym_names(sym_export) /''/ - data sym_names(sym_export_param) /''/ + data sym_names(sym_export_param) /'PM__export_param'/ data sym_names(sym_export_as_new) /''/ data sym_names(sym_amp_error) /''/ data sym_names(sym_also) /''/ @@ -910,7 +910,7 @@ module pm_symbol data sym_names(sym_get_tile_sz) /'PM__get_tilesz'/ data sym_names(sym_make_mask) /'PM__make_mask'/ data sym_names(sym_node_for) /'node_for'/ - data sym_names(sym_import_param) /'PM__impparam'/ + data sym_names(sym_import_param) /'PM__import_param'/ data sym_names(sym_set_elem) /'PM__setaelem'/ data sym_names(sym_assign_or_init) /'PM__assign_or_init'/ data sym_names(sym_assign_var) /'PM__assign_var'/ @@ -1304,7 +1304,7 @@ recursive subroutine pm_name_string(context,m,str) str='_'//trim(str2) else call pm_name_string(context,first,str) - str=trim(str)//'''_'//trim(str2) + str=trim(str)//'::_'//trim(str2) endif else str='?type' @@ -1313,7 +1313,7 @@ recursive subroutine pm_name_string(context,m,str) write(str,'(1h?,i8,1h?)') n endif else if(n<0) then - str='use ' + str='var ' call pm_name_string(context,-n,str(5:)) else str='EOF' diff --git a/src/types.f90 b/src/types.f90 index 3fa0d2a..dca5995 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -228,7 +228,6 @@ subroutine pm_init_types(context) context%tcache=pm_dict_new(context,128_pm_ln) context%pcache=pm_dict_new(context,1024_pm_ln) - context%vcache=pm_set_new(context,1024_pm_ln) key(1)=pm_type_is_basic do i=1,pm_null @@ -545,7 +544,7 @@ function pm_new_fix_value_type(context,val,vindex) result(tno) if(present(vindex)) then args(2)=vindex else - args(2)=pm_set_add(context,context%vcache,val) + args(2)=pm_set_add(context,context%names,val) endif args(3)=pm_fast_typeof(val) if(args(3)==pm_string) args(3)=pm_string_type @@ -554,6 +553,19 @@ function pm_new_fix_value_type(context,val,vindex) result(tno) include 'ftypeof.inc' end function pm_new_fix_value_type + function pm_fix_value_type_from_literal(context,tno) result(tno2) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: tno2 + integer:: args(3) + type(pm_ptr):: tv + tv=pm_type_vect(context,tno) + args(1)=pm_type_new_fix_value + args(2)=pm_tv_name(tv) + args(3)=pm_tv_arg(tv,1) + tno2=pm_new_basic_type(context,args,pm_type_val(context,tno)) + end function pm_fix_value_type_from_literal + !========================================== ! Create new compile time value type !========================================== @@ -567,7 +579,7 @@ function pm_new_literal_value_type(context,val,vindex) result(tno) if(present(vindex)) then args(2)=vindex else - args(2)=pm_set_add(context,context%vcache,val) + args(2)=pm_set_add(context,context%names,val) endif args(3)=pm_fast_typeof(val) if(args(3)==pm_string) args(3)=pm_string_type @@ -585,7 +597,7 @@ function pm_new_error_type(context,val) result(tno) integer:: tno integer,dimension(2):: args args(1)=pm_type_new_error - args(2)=pm_set_add(context,context%vcache,val) + args(2)=pm_set_add(context,context%names,val) tno=pm_new_basic_type(context,args,val) end function pm_new_error_type @@ -598,6 +610,7 @@ function pm_error_type_from_string(context,str) result(tno) integer:: tno tno=pm_new_error_type(context,pm_new_string(context,str)) end function pm_error_type_from_string + !============================================= ! Create new compile time proc value type @@ -1042,14 +1055,12 @@ function pm_type_combine_modes(context,array,is_cond,shared_ok) result(combined_ do i=1,size(array) tno=pm_type_strip_mode(context,array(i),mode) if(mode==sym_shared.and..not.shared_ok) then - if(iand(pm_type_flags(context,tno),pm_type_has_distributed)/=0) then - combined_mode=-i - return - endif + combined_mode=-i + return endif cmode=min(cmode,mode) enddo - if(cmode==sym_chan.or.cmode==sym_nhd) cmode=sym_private + if(cmode=sym_invar case(sym_complete) - ok=mode2>=sym_chan + ok=mode2>=sym_chan.and.mode2/=sym_uniform.and.mode2/=sym_joint case(sym_connected) ok=mode2>sym_private.or.mode2==sym_global& .or.mode2==sym_complete case(sym_individual) - ok=mode2>=sym_private.and.mode2=sym_private.and.mode2 Date: Mon, 28 Apr 2025 19:14:14 +0100 Subject: [PATCH 15/36] Restructure references --- src/codegen.f90 | 61 +++++++++++++++++++++++++++++++++++++++++-------- src/parser.f90 | 5 +++- 2 files changed, 55 insertions(+), 11 deletions(-) diff --git a/src/codegen.f90 b/src/codegen.f90 index 74be96e..9c6620b 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -1258,7 +1258,7 @@ subroutine trav_comm_ref(coder,cblock,pnode,node,islhs,isaliased) logical,intent(in):: islhs,isaliased type(pm_ptr):: arg integer:: i,j,n,sym - i=1 + i=2 n=node_numargs(node) if(node_sym(node)==sym_reference.and..not.isaliased) then @@ -1285,21 +1285,62 @@ subroutine trav_comm_ref(coder,cblock,pnode,node,islhs,isaliased) endif enddo endif - - do j=n,i,-1 + + if(i==n) return + + call trav_reference_as_list(coder,cblock,pnode,node,i,islhs) + + end subroutine trav_comm_ref + + subroutine trav_reference_as_list(coder,cblock,pnode,node,first_index,islhs) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + integer,intent(in):: first_index + logical,intent(in):: islhs + integer:: i,j,n,base,name,sym + type(pm_ptr):: arg + base=coder%vtop + n=node_numargs(node) + do j=first_index,n arg=node_arg(node,j) sym=node_sym(arg) - if(sym==sym_dot) then - - elseif(sym==sym_open_square) then + select case(sym) + case(sym_dot) + name=node_num_arg(node,1) + ! Convert name to literal "name" + call make_literal_const(coder,cblock,arg,& + pm_new_literal_value_type(coder%context,& + pm_name_val(coder%context,name),name)) + case(sym_sub) call trav_expr(coder,cblock,node,node_arg(node,1)) - else + case(sym_open_brace) call trav_expr(coder,cblock,node,node_arg(node,1)) - endif - call make_sys_call_rtn(coder,cblock,node,sym_pm_list,2,1) + call make_sp_call_rtn(coder,cblock,node,sym_list,1,1) + case(sym_open) + call trav_expr(coder,cblock,node,node_arg(node,1)) + call trav_expr(coder,cblock,node,node_arg(node,2)) + call make_sp_call_rtn(coder,cblock,node,sym_list,2,1) + case default + call pm_panic('Unexpected node in reference') + end select + enddo + + n=n-first_index+1 + if(first_index/=2) then + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) + endif + call dup_code(coder) + do i=1,n + call code_val(coder,coder%vstack(base+i)) + call make_comm_sys_call_rtn(coder,cblock,node_arg(node,i+1),sym_pm_ref,2,1) enddo - end subroutine trav_comm_ref + do j=1,n + call dup_expr(coder,coder%vstack(base+i)) + enddo + call make_sys_call_rtn(coder,cblock,node,sym_pm_list,2,1) + + end subroutine trav_reference_as_list subroutine check_alias(coder,cblock,node1,node2,str) type(code_state),intent(inout):: coder diff --git a/src/parser.f90 b/src/parser.f90 index 88cd6b6..c39a84d 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1453,7 +1453,7 @@ recursive function qual(parser,dot_call) result(iserr) if(expect(parser,sym_close)) return call make_node_at(parser,sym_open,2,line,pos) else - call make_node_at(parser,sym_get_dot,1,line,pos) + call make_node_at(parser,sym_open_brace,1,line,pos) endif n=n+1 case default @@ -1486,6 +1486,9 @@ recursive function qual(parser,dot_call) result(iserr) n=n+1 case(sym_open_square) call get_sym_pos(parser,line,pos) + call push_sym_val(parser,sym_tuple) + if(subscript(parser)) return + call simple_call(parser) if(subscript(parser)) return call make_node_at(parser,sym_sub,1,line,pos) n=n+1 From 2a8c8e2db8516aec3b2362d8465d0bc10cf109a8 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 8 May 2025 20:09:44 +0100 Subject: [PATCH 16/36] More reference refactoring --- src/ast.f90 | 1 + src/codegen.f90 | 579 +++++++++++++++++++++--------------------------- src/infer.f90 | 33 +-- src/parser.f90 | 121 +++++++--- src/symbol.f90 | 24 +- src/types.f90 | 26 +-- 6 files changed, 369 insertions(+), 415 deletions(-) diff --git a/src/ast.f90 b/src/ast.f90 index 0cfc4f9..caedeba 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -113,6 +113,7 @@ module pm_ast integer,parameter:: proccall_is_no_inline= 32 integer,parameter:: proccall_is_yield= 64 + integer,parameter:: proccall_is_lhs= 128 integer,parameter:: proc_is_cond= 256 integer,parameter:: proc_is_uncond= 512 integer,parameter:: proc_run_complete= 2**10 diff --git a/src/codegen.f90 b/src/codegen.f90 index 9c6620b..dbe5288 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -488,12 +488,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_call(coder,cblock,node,node_arg(node,3),0,.true.) if(xbase>=0) call hide_where_vars(coder,xbase+1,xtop) endif - case(sym_invar) - call trav_mode_stmt(coder,cblock,node,sym,sym_invar_stmt) - case(sym_shared) - call trav_mode_stmt(coder,cblock,node,sym,sym_shared_stmt) - case(sym_chan) - call trav_mode_stmt(coder,cblock,node,sym,sym_chan_stmt) case(sym_for,sym_forall) call trav_for_stmt(coder,cblock,list,node) case(sym_each,sym_foreach_invar) @@ -1171,6 +1165,8 @@ recursive subroutine trav_all_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node integer:: base,xtop + type(pm_ptr):: var,arg1,arg3 + integer:: sym1,sym3 if(coder%par_state==par_state_none) then call code_error(coder,node,& 'Cannot have an "all" statement outside of a parallel context') @@ -1178,205 +1174,229 @@ recursive subroutine trav_all_stmt(coder,cblock,pnode,node) call code_error(coder,node,& 'In a conditional statement, an "all" statement must be enclosed by a "sync" statement') endif + + arg1=node_arg(node,1) + sym1=node_sym(arg1) + arg3=node_arg(node,3) + sym3=node_sym(arg3) + call trav_subexpr(coder,cblock,node,node_arg(node,4),base,xtop) - call trav_comm_ref(coder,cblock,node,node_arg(node,1),.true.,.false.) + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),.true.) + var=top_code(coder) + call trav_expr(coder,cblock,node,node_arg(node,2)) - call trav_expr(coder,cblock,node,node_arg(node,3)) - call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3,0) + call trav_expr(coder,cblock,node,arg3) + + if(node_sym(arg1)==sym_reference) then + !call trav_comm_ref(coder,cblock,node,arg1,.true.,.true.,var) + call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3+node_numargs(arg1),0) + else + call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3,0) + endif if(base>=0) call hide_where_vars(coder,base+1,xtop) + end subroutine trav_all_stmt - subroutine trav_ref(coder,cblock,pnode,node,islhs,call_sym) + subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - logical,intent(in):: islhs - integer,intent(in),optional:: call_sym - integer:: n,flags - logical:: maybe_not_private - if(node_sym(node)==sym_name) then + logical,intent(in):: islhs,skipdot,isalias + integer,intent(out),optional:: call_n + type(pm_ptr):: arg + integer:: i,j,n,sym,start,base,vbase + logical:: iscomm,isvar + + sym=node_sym(node) + if(sym==sym_name) then call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) - n=1 - elseif(node_sym(node)==sym_reference) then - call trav_ref_to_var(coder,cblock,node,node_num_arg(node_arg(node,1),1),islhs) - flags=cnode_get_num(top_code(coder),var_flags) - maybe_not_private=iand(flags,var_is_maybe_not_private)/=0 - if(maybe_not_private) then - call trav_comm_ref(coder,cblock,pnode,node,islhs,.false.) - n=2 - else - call trav_simple_ref(coder,cblock,pnode,node,islhs) - n=1 - endif + return endif - if(present(call_sym)) then - if(coder%par_state==par_state_none) then - call make_sys_call_rtn(coder,cblock,node,call_sym,n,1) + + arg=node_arg(node,1) + if(node_sym(arg)==sym_name) then + call trav_ref_to_var(coder,cblock,arg,node_num_arg(arg,1),islhs) + isvar=.true. + else + call trav_expr(coder,cblock,node,arg) + isvar=.false. + endif + + start=2 + arg=node_arg(node,start) + sym=node_sym(arg) + if(sym==sym_pling) then + call make_comm_sys_call(coder,cblock,node,sym_pm_pling,1,1) + iscomm=.true. + start=3 + elseif(sym==sym_at) then +!!! need the @[] part + + call make_comm_sys_call(coder,cblock,node,sym_pm_at,1,1) + iscomm=.true. + start=3 + else + arg=top_code(coder) + if(cnode_get_kind(arg)==cnode_is_var) then + iscomm=cnode_flags_set(top_code(coder),var_flags,var_is_maybe_not_private) else - call make_comm_sys_call_rtn(coder,cblock,node,call_sym,n,1) + iscomm=.false. endif endif - end subroutine trav_ref - subroutine trav_simple_ref(coder,cblock,pnode,node,islhs) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - logical,intent(in):: islhs - integer:: i,n,m,sym - type(pm_ptr):: arg,list + vbase=coder%vtop + base=coder%vtop-start+2 + n=node_numargs(node) - do i=2,n + do i=start,n arg=node_arg(node,i) sym=node_sym(arg) select case(sym) case(sym_dot) - call make_const(coder,cblock,node,node_arg(node,1)) - call make_sp_call_rtn(coder,cblock,node,sym_dot,2,1) + call code_name_as_string(coder,cblock,arg,node_num_arg(arg,1)) + case(sym_open_brace) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + call make_sp_call(coder,cblock,arg,sym_open_brace,1,0,flags=call_is_no_touch) case(sym_sub) - list=node_arg(node,1) - call trav_exprlist(coder,cblock,node,list) - call make_sys_call_rtn(coder,cblock,node,sym_sub,1+node_numargs(list),1) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) case(sym_open) - list=node_arg(node,2) - m=node_numargs(list) - call trav_exprlist(coder,cblock,node,list) - call make_arglist(coder,cblock,node,m,1,.false.,.true.) - call code_null(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_full_call(coder,cblock,node,pm_fast_tinyint(coder%context,0),& - pm_null_obj,1+m,1,0,pm_null_obj,& - proccall_is_comm+proccall_is_general+proccall_is_ref,pop_code(coder)) - call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + call trav_expr(coder,cblock,arg,node_arg(arg,2)) + call make_sp_call_rtn(coder,cblock,node,sym_list,2,1) end select enddo - contains - include 'ftiny.inc' - end subroutine trav_simple_ref - subroutine trav_comm_ref(coder,cblock,pnode,node,islhs,isaliased) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - logical,intent(in):: islhs,isaliased - type(pm_ptr):: arg - integer:: i,j,n,sym - i=2 - n=node_numargs(node) + call code_val(coder,coder%vstack(vbase)) - if(node_sym(node)==sym_reference.and..not.isaliased) then - do while(i<=n) + i=start + + if(skipdot) then + arg=node_arg(node,i) + sym=node_sym(arg) + do while(sym==sym_dot.or.sym==sym_open_brace) + call code_val(coder,coder%vstack(base+i)) + call make_sp_call_rtn(coder,cblock,arg,sym_dot,2,1) + i=i+1 + if(i>n) exit arg=node_arg(node,i) - sym=node_sym(node) - if(sym==sym_dot) then - call code_val(coder,node_arg(arg,1)) - call make_sp_call_rtn(coder,cblock,node,sym_dot,2,1) - i=i+1 + sym=node_sym(arg) + enddo + endif + + if(ii)) then + if(xaliased(k,j)) then + call code_val(coder,coder%vstack(base+i*2-1)) + call code_val(coder,coder%vstack(base+j*2-1)) + call make_sys_call(coder,cblock,node_arg(node,i),& + sym_check_alias,2,0) + endif + endif + enddo + endif + enddo + do i=1,nargs + coder%vstack(base+i)=coder%vstack(base+2*i) + enddo + coder%vtop=coder%vtop-nargs + else + do i=1,nargs + arg=node_arg(node,i) + if(is_amp(i)) then + call trav_reference(coder,cblock,node,arg,.true.,.true.,.false.) + else + call trav_expr(coder,cblock,node,arg) + endif + enddo + endif end subroutine process_amp_args end subroutine trav_call diff --git a/src/infer.f90 b/src/infer.f90 index 5bce32c..2aece0c 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -1113,30 +1113,17 @@ subroutine inf_call(coder,cblock,callnode) tno2=pop_word(coder) tno2=pm_type_add_mode(coder%context,tno2,mode) call combine_types(cnode_arg(args,1),tno2) - case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref) - if(sig==sym_get_dot.or.sig==sym_get_dot_ref) then - tno=arg_type(3) - if(tno/=error_type) then - namep=pm_type_vect(coder%context,arg_type(3)) - name=pm_tv_name(namep) - namep=pm_fast_name(coder%context,name) - else - call set_arg_to_error_type(1) - return - endif - else - namep=cnode_arg(cnode_arg(args,3),1) - name=namep%offset - endif - tno=arg_type_with_mode(2) - if(tno==error_type) then - call set_arg_to_error_type(1) - else + case(sym_dot,sym_dot_ref) + name=arg_type(3) + tno=arg_type_with_mode(2) + if(tno==error_type) then + call set_arg_to_error_type(1) + else tno=pm_type_strip_mode(coder%context,& tno,mode) if(tno>0) then call set_call_sig(resolve_elem(cnode_arg(args,2),tno,name,& - sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) + sig==sym_dot_ref,.false.,tno2)) call combine_types(cnode_arg(args,1),& pm_type_add_mode(coder%context,tno2,mode)) else @@ -1766,15 +1753,15 @@ end subroutine set_call_sig !================================================================== ! Resolve signature for item.name !================================================================== - recursive function resolve_elem(var,tno,name,isref,isopt,elem_type) result(sig) + recursive function resolve_elem(var,tno,nametyp,isref,isopt,elem_type) result(sig) type(pm_ptr),intent(in):: var - integer,intent(in):: tno,name + integer,intent(in):: tno,nametyp logical,intent(in):: isref,isopt integer,intent(out):: elem_type integer:: sig,tk type(pm_ptr):: svec - sig=pm_type_find_elem(coder%context,tno,name,isref,& + sig=pm_type_find_elem(coder%context,tno,nametyp,isref,& elem_type) if(sig==0) then if(.not.isopt) then diff --git a/src/parser.f90 b/src/parser.f90 index c39a84d..e307983 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1427,6 +1427,10 @@ recursive function qual(parser,dot_call) result(iserr) call scan(parser) call make_node(parser,sym_pling,0) n=n+1 + elseif(parser%sym==sym_at) then + call scan(parser) + call make_node(parser,sym_at,0) + n=n+1 endif do select case(parser%sym) @@ -1489,7 +1493,6 @@ recursive function qual(parser,dot_call) result(iserr) call push_sym_val(parser,sym_tuple) if(subscript(parser)) return call simple_call(parser) - if(subscript(parser)) return call make_node_at(parser,sym_sub,1,line,pos) n=n+1 case default @@ -4280,9 +4283,11 @@ end function opt_moded_typ_list !====================================================== ! Parameter list for procedure declaration !====================================================== - recursive function param_list(parser,iscomm) result(iserr) + recursive function param_list(parser,iscomm,dot_name,dot_type,close) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: iscomm + type(pm_ptr),intent(in):: dot_name,dot_type + integer,intent(in):: close logical:: iserr integer:: m,n,i,base,last,vbase,sym,msym,name,numloop type(pm_ptr):: temp,dom @@ -4297,7 +4302,7 @@ recursive function param_list(parser,iscomm) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4311,7 +4316,7 @@ recursive function param_list(parser,iscomm) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4322,7 +4327,7 @@ recursive function param_list(parser,iscomm) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4333,7 +4338,7 @@ recursive function param_list(parser,iscomm) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4345,7 +4350,7 @@ recursive function param_list(parser,iscomm) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4356,7 +4361,7 @@ recursive function param_list(parser,iscomm) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4364,9 +4369,15 @@ recursive function param_list(parser,iscomm) result(iserr) endif m=num_comm_args endif + + if(.not.pm_fast_isnull(dot_name)) then + call push_val(parser,dot_name) + call push_val(parser,dot_type) + m=m+1 + endif ! Empty argument list - if(parser%sym==sym_close) then + if(parser%sym==close) then call make_node(parser,sym_list,m*2) call push_null_val(parser) call push_null_val(parser) @@ -4460,6 +4471,9 @@ recursive function param_list(parser,iscomm) result(iserr) enddo else if(n>0) then + if(.not.pm_fast_isnull(dot_name)) then + call parse_error(parser,'A method cannot have keyword arguments') + endif call make_node(parser,sym_list,n*3) else call push_null_val(parser) @@ -4479,12 +4493,14 @@ recursive function param_list(parser,iscomm) result(iserr) call push_null_val(parser) endif - if(expect(parser,sym_close)) return + if(expect(parser,close)) return iserr=.false. return contains + include 'fisnull.inc' + function arg_typ_with_mode(iscomm) result(iserr) logical,intent(in):: iscomm logical:: iserr @@ -4551,15 +4567,15 @@ end function proc_attr function proc_decl(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr - type(pm_ptr),target::ptr,dom,dparams,rtypes + type(pm_ptr),target::ptr,dom,dparams,rtypes,dot_name,dot_type type(pm_ptr):: p,params,link type(pm_reg),pointer:: reg integer:: name,callname,this,thispar integer:: nret,base,flags,sbase,scount,m,nreduce,sym - integer:: line,pos,nerrors + integer:: line,pos,nerrors,open,close logical:: ampargs,iscall,iscomm,isref,isshared,islocal,ischan,have_rtn nerrors=parser%error_count - reg=>pm_register(parser%context,'proc',ptr,dom,dparams,rtypes) + reg=>pm_register(parser%context,'proc',ptr,dom,dparams,rtypes,dot_name,dot_type) iserr=.true. sym=sym_proc nret=0 @@ -4569,28 +4585,58 @@ function proc_decl(parser) result(iserr) dom=pm_null_obj dparams=pm_null_obj thispar=-1 + open=sym_open + close=sym_close ! Line and position of procedure start call get_sym_pos(parser,line,pos) call scan(parser) - - ! Reference procedure proc .name(...) + iscomm=.false. isref=.false. - if(parser%sym==sym_dot) then + if(parser%sym==sym_open) then + ! Reference procedure proc (name:type).name(...) call scan(parser) + if(parser%sym==sym_amp) then + flags=ior(flags,proccall_is_lhs) + call scan(parser) + endif + if(expect_name(parser)) goto 999 + dot_name=pop_val(parser) + if(parser%sym==sym_colon) then + call scan(parser) + if(moded_typ(parser,.true.,.false.)) goto 999 + dot_type=pop_val(parser) + else + dot_type=pm_null_obj + endif + if(expect(parser,sym_close)) goto 999 + if(parser%sym==sym_open_square) then + name=sym_sub + open=sym_open_square + close=sym_close_square + else + if(expect(parser,sym_dot)) goto 999 + if(expect_name(parser)) goto 999 + name=pop_num_val(parser) + endif flags=ior(flags,proccall_is_ref+proccall_is_comm+proccall_is_general) iscomm=.true. isref=.true. - endif - - ! Procedure name - if(.not.check_name(parser,name)) then - if(.not.isref) then - if(op(parser,name,.false.,.false.)) goto 999 + else + + ! Procedure name + if(.not.check_name(parser,name)) then + if(.not.isref) then + if(op(parser,name,.false.,.false.)) goto 999 + endif endif - endif + dot_name=pm_null_obj + dot_type=pm_null_obj + + endif + ! Communicating proc flags if(.not.isref) then if(parser%sym==sym_pct) then @@ -4605,7 +4651,7 @@ function proc_decl(parser) result(iserr) endif ! Start of parameters - if(expect(parser,sym_open)) goto 999 + if(expect(parser,open)) goto 999 10 continue @@ -4623,7 +4669,7 @@ function proc_decl(parser) result(iserr) ! Push some more entries in the procedure node (some get values later) call push_val(parser,parser%modl) call push_num_val(parser,-12345) ! flags - if(param_list(parser,iscomm)) goto 999 + if(param_list(parser,iscomm,dot_name,dot_type,close)) goto 999 params=parser%vstack(parser%vtop-2) call push_num_val(parser,-777) ! coded returns @@ -4701,7 +4747,7 @@ function proc_decl(parser) result(iserr) m=0 do - if(isref) then + if(iand(flags,proccall_is_lhs)/=0) then if(m>0) then call parse_error(parser,& 'Cannot return more than one value from reference "." procedure') @@ -4828,7 +4874,9 @@ function yield_clause() result(iserr) integer:: m,n,i,k,base,first type(pm_ptr):: params,amps iserr=.true. - if(iand(flags,proccall_is_comm)/=0) then + if(iand(flags,proccall_is_ref)/=0) then + call parse_error(parser,'Cannot have a "yield" clause in a method') + elseif(iand(flags,proccall_is_comm)/=0) then first=num_comm_args+1 else first=2 @@ -4890,7 +4938,7 @@ function return_stmt() result(iserr) call scan(parser) m=0 do - if(isref) then + if(iand(flags,proccall_is_lhs)/=0) then if(m>0) then call parse_error(parser,& 'Cannot return more than one value from reference "." procedure') @@ -5779,13 +5827,6 @@ subroutine decl(parser,is_root_module) do select case(parser%sym) case(sym_proc) - call scan(parser) - if(parser%sym==sym_open) then - call push_back(parser,sym_proc) - exit - else - call push_back(parser,sym_proc) - endif if(proc_decl(parser)) goto 999 case(sym_type) if(typ_decl(parser)) goto 999 @@ -6133,6 +6174,16 @@ subroutine push_num_val(parser,n) include 'ftiny.inc' end subroutine push_num_val + !====================================================== + ! Pop a tiny integer from the value stack + !====================================================== + function pop_num_val(parser) result(num) + type(parse_state),intent(inout):: parser + integer:: num + num=parser%vstack(parser%vtop)%offset + parser%vtop=parser%vtop-1 + end function pop_num_val + !====================================================== ! Push token on to value stack !====================================================== diff --git a/src/symbol.f90 b/src/symbol.f90 index 472170e..6381f47 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -385,8 +385,8 @@ module pm_symbol integer,parameter:: sym_pm_forall_stmt = hook + 40 integer,parameter:: sym_pm_over_stmt = hook + 41 integer,parameter:: sym_pm_par_stmt = hook + 42 - integer,parameter:: sym_lhs_and_val = hook + 43 - integer,parameter:: sym_rhs_and_val = hook + 44 + integer,parameter:: sym_lhs = hook + 43 + integer,parameter:: sym_rhs = hook + 44 integer,parameter:: sym_make_var= hook + 45 integer,parameter:: sym_make_chan_var = hook + 46 integer,parameter:: sym_make_nhd_var = hook + 47 @@ -394,9 +394,9 @@ module pm_symbol integer,parameter:: sym_make_invar_var = hook + 49 integer,parameter:: sym_make_shared_var = hook + 50 integer,parameter:: sym_make_const = hook + 51 - integer,parameter:: sym_chan_stmt = hook + 52 - integer,parameter:: sym_invar_stmt = hook + 53 - integer,parameter:: sym_shared_stmt = hook + 54 + integer,parameter:: sym_pm_at = hook + 52 + integer,parameter:: sym_pm_pling = hook + 53 + integer,parameter:: sym_lcl_stmt = hook + 54 integer,parameter:: sym_dechan = hook + 55 integer,parameter:: sym_check_iter = hook + 56 integer,parameter:: sym_check_iter_amp = hook + 57 @@ -514,7 +514,7 @@ module pm_symbol integer,parameter:: sym_blocking = hook5 + 25 integer,parameter:: sym_chunks = hook5 + 26 integer,parameter:: sym_get_chunk = hook5 + 27 - integer,parameter:: sym_pm_at = hook5 + 28 + integer,parameter:: sym_pm_atz = hook5 + 28 integer,parameter:: sym_push_mess = hook5 + 29 integer,parameter:: sym_pop_sync_mess = hook5 + 30 integer,parameter:: sym_join_param = hook5 + 31 @@ -854,8 +854,8 @@ module pm_symbol data sym_names(sym_pm_forall_stmt) /'PM__forall_stmt'/ data sym_names(sym_pm_over_stmt) /'PM__over_stmt'/ data sym_names(sym_pm_par_stmt) /'PM__par_stmt'/ - data sym_names(sym_lhs_and_val) /'PM__lhs_and_val'/ - data sym_names(sym_rhs_and_val) /'PM__rhs_and_val'/ + data sym_names(sym_lhs) /'PM__lhs'/ + data sym_names(sym_rhs) /'PM__rhs_and_val'/ data sym_names(sym_make_var) /'PM__make_var'/ data sym_names(sym_make_chan_var) /'PM__make_chan_var'/ data sym_names(sym_make_nhd_var) /'PM__make_nhd_var'/ @@ -864,9 +864,9 @@ module pm_symbol data sym_names(sym_make_shared_var) /'PM__make_shrd_var'/ data sym_names(sym_make_const) /'PM__make_const'/ - data sym_names(sym_chan_stmt) /'PM__chan_stmt'/ - data sym_names(sym_invar_stmt) /'PM__invar_stmt'/ - data sym_names(sym_shared_stmt) /'PM__shrd_stmt'/ + data sym_names(sym_pm_at) /'PM__chan_stmt'/ + data sym_names(sym_pm_pling) /'PM__invar_stmt'/ + data sym_names(sym_lcl_stmt) /'PM__shrd_stmt'/ data sym_names(sym_dechan) /'PM__dechan'/ data sym_names(sym_check_iter) /'PM__check_iter'/ @@ -989,7 +989,7 @@ module pm_symbol data sym_names(sym_dim_noinit) /'PM__dim_noinit'/ data sym_names(sym_chunks) /'chunks'/ data sym_names(sym_get_chunk) /'chunk'/ - data sym_names(sym_pm_at) /'PM__at'/ + data sym_names(sym_pm_atz) /'PM__atz'/ data sym_names(sym_pm_node) /'PM__node'/ data sym_names(sym_init_const) /'PM__init_const'/ diff --git a/src/types.f90 b/src/types.f90 index dca5995..8313ce6 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -2127,14 +2127,15 @@ end function pm_proc_type_conforms ! offset<0 Returns dref rather than sub-element ! If offset/=0 then etype returns the type of the element !================================================================= - recursive function pm_type_find_elem(context,tno,name,change,etype) result(offset) + recursive function pm_type_find_elem(context,tno,nametype,change,etype) result(offset) type(pm_context),pointer:: context - integer,intent(in):: tno,name + integer,intent(in):: tno,nametype logical,intent(in):: change integer,intent(out):: etype integer:: offset,ptype,mode type(pm_ptr):: tv - integer:: tk,i + integer:: tk,i,name + name=pm_type_name(context,nametype) if(tno<0) then offset=0 return @@ -2152,25 +2153,6 @@ recursive function pm_type_find_elem(context,tno,name,change,etype) result(offse enddo offset=0 return - case(pm_type_is_dref) -!!$ offset=pm_type_find_elem(context,& -!!$ pm_type_strip_mode(context,pm_tv_arg(tv,1),mode),& -!!$ name,change,stack,top,& -!!$ maxstack,etype) -!!$ if(offset==0) then -!!$ return -!!$ else -!!$ offset=-offset -!!$ endif -!!$ call push(pm_type_new_dref) -!!$ call push(name) -!!$ call push(pm_type_add_mode(context,etype,mode)) -!!$ call push(tno) -!!$ do i=3,pm_tv_numargs(tv) -!!$ call push(pm_tv_arg(tv,i)) -!!$ enddo -!!$ etype=pm_new_type(context,stack(top-pm_tv_numargs(tv)-1:top)) -!!$ top=top-pm_tv_numargs(tv)-2 case(pm_type_is_rec) call pm_type_elem_offset(context,tv,name,change,offset,etype) case default From 421ef720d02aa76d4b297254d5495628625c6e0e Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 12 May 2025 17:15:19 +0100 Subject: [PATCH 17/36] Change LHS syntax --- pm/lib/sys/pm.pmm | 329 +++++++++++++++++++++++++++++++++++++++++++--- src/codegen.f90 | 81 ++++++++---- src/infer.f90 | 6 +- src/parser.f90 | 251 +++++++++++++++++++++-------------- src/symbol.f90 | 10 +- src/wcoder.f90 | 2 +- 6 files changed, 531 insertions(+), 148 deletions(-) diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm index 9134e50..c9259b2 100644 --- a/pm/lib/sys/pm.pmm +++ b/pm/lib/sys/pm.pmm @@ -1040,8 +1040,6 @@ proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", // RANGES AND SEQUENCES // ***************************************************** -/* - // Not in operator proc notin(x,y)=not(x in y) @@ -1159,6 +1157,7 @@ proc empty(x:range)=rec range { _lo=x._hi,_hi=x._lo,_n=0 } proc string(x:range)=string(x._lo)++".."++(x._hi) + // Cyclic range types (limited functionality and not part of grid) type cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int} proc cyclic_range(x:int,y:int,w:int)=rec cyclic_range { @@ -1168,9 +1167,10 @@ proc high(x:cyclic_range)=x._hi proc size(x:cyclic_range)=x._n proc element(x:cyclic_range,y:int)=(x._lo + y) mod x._w proc string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")" + // Strided range types type strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int} -type _any_seq(t:range_base):iterable is strided_range(t), ... +type _any_seq(t:range_base) is strided_range(t), ... type _any_seq(t:any_int) is ..., range(t) type seq(t:range_base) is _any_seq(t) proc _seq(lo,hi,st)=rec strided_range { @@ -1240,7 +1240,287 @@ proc empty(x:strided_range(any_int))=rec strided_range { _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 } +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=rec block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #(x:block_seq)=shape([0..x._n-1]) +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=rec block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=rec block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) + +/* +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:grid_dim){ + var a=array(0,#x) + forall i in a,j in x:i=j + return rec map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=rec map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + /* + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +*/ +} +proc map_seq(x:map_seq)=x +proc #(x:map_seq)=#(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=rec map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=rec map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=rec map_seq { + array=a[ns] + } + w=rec map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=rec map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return rec map_seq { + array=a + } +} */ +proc map_seq(x)=x +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) + +// Grids (tuples of sequences) +type _grid_dim(t:range_base) is seq(t),... +type _grid_dim(t:int) is ...,block_seq //,map_seq +type grid_dim(t:range_base) is _grid_dim(t) +type grid1d(t1:grid_dim) is [t1] +type grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2] +type grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is [t1,t2,t3] +type grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is [t1,t2,t3,t4] +type grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim) is [t1,t2,t3,t4,t5] +type grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim) is [t1,t2,t3,t4,t5,t6] +type grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim,t7:grid_dim) is [t1,t2,t3,t4,t5,t6,t7] +type grid(t:range_base) is tuple(grid_dim(t)) +proc #(x:grid)=shape(map($_shp,x)) +proc dims(x:grid)=map($_size,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($+,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:grid_dim,y:grid_dim){ + var a=array(0,#y) + forall i in a,j in y:i=x[j] + return rec map_seq{ + array=a + } +} +proc element(x:grid,y:grid)=map($element,x,y) + +// Slices of grids (may have dims that are just an integer and also _ or _() or null) +type grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null +type grid_slice(t) is grid(t),tuple(grid_slice_dim(t)) + +// Some limited functionality for extended grids (which include cyclic ranges) +type iterable_dim is grid_slice_dim,cyclic_range,... +type iterable_grid is tuple(iterable_dim),grid_slice +proc _shp(x:iterable_dim)=0..size(x)-1 +proc size(x:iterable_dim)->(int)... +proc element(x:iterable_dim,y)=error_type()check "Cannot index this type with a non-integer index"=>fix(false) +proc element(x:iterable_dim,y:int)->(any)... +proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) +proc _shp(x:stretch_dim)=null +proc _shp(x:null)=x +proc _size(x:stretch_dim or null)=fix(1) +proc _size(x)=size(x) +PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" +proc _act(x)=x +proc _sliceit(...)=tuple(...) +proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) +proc active_dims(x:single_point)=null +PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _act(x,y)=y +proc active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y) +proc active_dims(x:single_point,y)=null +proc _ar(x:single_point)=0 +proc _ar(x)=1 +proc rank(x:iterable_grid)=map_reduce($_ar,$+,x) +proc element(x:iterable_grid,y:index){ + t=_tup(y) + return _ges(head(x),tail(x),head(t),tail(t),fix(false)) +} +proc element(x:grid_slice,...:grid_slice){ + t=_tup(...) + return _ges(head(x),tail(x),head(t),tail(t),fix(true)) +} +proc element(x:null,y)=null +proc _spnt(i,y:fix(true))=i +proc _spnt(i,y:fix(false))=i._t +proc _spif(i:int,y:fix(true))=single_point(i) +proc _spif(i,y:fix(true))=i +proc _spif(i,y:fix(false))=i +proc _ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => fix(false) +proc _ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:fix(true))=prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:fix(false))=_ges(head(x),tail(x),head(y),tail(y),t) +proc _ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t) +proc _ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j:empty_head,y,t)=null +proc _ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => fix(false) +proc _ges(i:null,x,j:empty_head,y,t:fix(true))=error_type() :test "Rank mismatch" => fix(false) +proc _ges(i:null,x,j:empty_head,y,t:fix(false))=null +proc size(x:iterable_grid)=map_reduce($_size,$*,x) +proc #(x:grid_slice)=shape(map($_shp,active_dims(x))) +proc dims(x:iterable_grid)=map($_size,active_dims(x)) +proc _arb(x:grid_slice)=map($_arb,x) +proc in(x:tuple(range_base),y:grid_slice)=map_reduce($in,$and,x,y) +proc inc(x:grid_slice,y:grid_slice)=map_reduce($inc,$and,x,y) +proc #(x:grid,y:tuple(subs_dim))=map($#,x,y) +PM__intrinsic _acthash(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _acthash(x,y)=x#y +proc #(x:grid_slice,y:tuple(subs_dim) or grid_slice)=map_apply($_acthash,$_sliceit,x,y) +proc convert(x:grid_slice,y:real_num)=map_const($convert,x,y) +proc sint(x:grid_slice)=map($sint,x) +proc int(x:grid_slice)=map($int,x) +proc sreal(x:grid_slice)=map($sreal,x) +proc real(x:grid_slice)=map($real,x) +proc low(x:grid_slice)=map($low,x) +proc high(x:grid_slice)=map($high,x) +proc overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y) +proc overlap(x:grid_slice,y:grid_slice)=u,v where u,v=map($overlap,x,y) +proc intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y) +proc intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y)) +proc expand(x:grid_slice,y:grid)=map($expand,x,y) +proc contact(x:grid_slice,y:grid)=map($contract,x,y) +PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" + // *************************************************** // LOOPS AND PARALLEL STATEMENTS @@ -1264,6 +1544,9 @@ proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) < } } +proc PM__par_stmt'(num) yield() <> { yield() } +proc PM__check_task'(num)=true + proc PM__chan_stmt'() yield() { yield() } proc PM__over_stmt'(x) yield() { yield() } @@ -1348,20 +1631,13 @@ proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) +/* // Assignment proc PM__assign_or_init(a,b)<>=a { PM__assign_var(&^(a),b) } +*/ -proc PM__assign_or_init(a:,b)=PM__dup(b as a) - -proc PM__assign_var(&a,b) { - PM__assign(&a,b) -} - -proc PM__assign(&a:any,b:any) { - _assign(&a,c) where c=b as a -} /* type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... @@ -1400,11 +1676,30 @@ PM__intrinsic _assign_element(&any,any): "assign" // Other variable operations +proc PM__assign_or_init(&a:PM__assign_or_init,b)=PM__dup(b as a) + +proc PM__assign_or_init(&a,b)=a:PM__assign(&a,b) + +proc PM__init_const(&a:PM__assign_or_init,b)=PM__dup(b as a) + +proc PM__init_const(&a,b)=a check "Cannot initialise a constant twice"=>fix(false) + +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} + +proc PM__dup(x)=x + +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a +} + PM__intrinsic PM__clone(x:any)->(=x) : "clone" PM__intrinsic PM__make_var(x:any)->(=x) : "clone" PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" +PM__intrinsic PM__make_const(x:any)->(=x) : "clone_var" PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" /* @@ -1451,11 +1746,11 @@ PM__intrinsic<> element_at_index(x:any,y:fix(int))->(|x):"elem" proc elements(x)=_elements(x,1) proc _elements(x,i:literal(int)) { - const e + let e... if fix(i==num_elements(x)) { - e=_cons(PM__element_at(x,i),_list_end) + let ...e=_cons(PM__element_at(x,i),_list_end) } else { - e=_cons(PM__element_at(x,i),_elements(x,i+1)) + let ...e=_cons(PM__element_at(x,i),_elements(x,i+1)) } return e } @@ -1506,6 +1801,10 @@ proc PM__copy_out(&a,b):a=b proc PM__for_in(a)=a proc PM__for_var(a)=a +proc PM__import_param'(x)=x +proc PM__export_param'(x)=x +proc PM__import_param'(&x,y){} + proc PM__make_over'(a)=a PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_concat" diff --git a/src/codegen.f90 b/src/codegen.f90 index dbe5288..5a223c6 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -1197,13 +1197,19 @@ recursive subroutine trav_all_stmt(coder,cblock,pnode,node) end subroutine trav_all_stmt + !================================================================ + ! Traverse a reference leaving an object or object reference + ! on vstack + ! If isalias is true then a second element on the stack is a + ! list of reference elements to be used in alias checking + !================================================================ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node logical,intent(in):: islhs,skipdot,isalias integer,intent(out),optional:: call_n type(pm_ptr):: arg - integer:: i,j,n,sym,start,base,vbase + integer:: i,j,n,sym,start,base,vbase,abase,atop logical:: iscomm,isvar sym=node_sym(node) @@ -1224,20 +1230,23 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) start=2 arg=node_arg(node,start) sym=node_sym(arg) + abase=coder%vtop if(sym==sym_pling) then - call make_comm_sys_call(coder,cblock,node,sym_pm_pling,1,1) + call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_pling,1,1) iscomm=.true. start=3 elseif(sym==sym_at) then -!!! need the @[] part - - call make_comm_sys_call(coder,cblock,node,sym_pm_at,1,1) + call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_at,1,merge(2,1,isalias)) iscomm=.true. start=3 else arg=top_code(coder) if(cnode_get_kind(arg)==cnode_is_var) then - iscomm=cnode_flags_set(top_code(coder),var_flags,var_is_maybe_not_private) + if(isvar) then + iscomm=cnode_flags_set(arg,var_flags,var_is_maybe_not_private) + else + iscomm=coder%par_state/=par_state_none + endif else iscomm=.false. endif @@ -1265,6 +1274,8 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) end select enddo + atop=coder%vtop + call code_val(coder,coder%vstack(vbase)) i=start @@ -1301,10 +1312,10 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) if(isalias) then call dup_expr(coder,coder%vstack(vbase)) - do j=start,n + do j=abase+1,atop call dup_expr(coder,coder%vstack(base+j)) enddo - call make_sp_call_rtn(coder,cblock,node,sym_list,n-start+1,1) + call make_sp_call_rtn(coder,cblock,node,sym_list,atop-abase+1,1) coder%vstack(vbase)=coder%vstack(coder%vtop-1) coder%vstack(vbase+1)=coder%vstack(coder%vtop) coder%vtop=vbase+1 @@ -1312,8 +1323,6 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) coder%vstack(vbase)=coder%vstack(coder%vtop) coder%vtop=vbase endif - - end subroutine trav_reference @@ -2664,13 +2673,31 @@ recursive subroutine trav_assign_define(coder,cblock,pnode,node) lhs=node_arg(node,1) rhs=node_arg(node,2) sym=node_sym(lhs) - n=node_numargs(lhs) - if(sym/=sym_assign.and.sym/=sym_where) n=n-2 + n=lhs_size(lhs) call trav_rhs(coder,cblock,node,rhs,n) call trav_lhs(coder,cblock,node,lhs,rhs) coder%vtop=base end subroutine trav_assign_define + !======================================================== + ! Number of elements in LHS node + !======================================================== + recursive function lhs_size(lhs) result(n) + type(pm_ptr),intent(in):: lhs + integer:: n + integer:: sym,i + n=node_numargs(lhs) + sym=node_sym(lhs) + if(sym==sym_assign_list) then + n=0 + do i=1,node_numargs(lhs) + n=n+lhs_size(node_arg(lhs,i)) + enddo + elseif(sym/=sym_assign.and.sym/=sym_where) then + n=n-2 + endif + end function lhs_size + !======================================================== ! Traverse multiple assignments, var/const definitions !======================================================== @@ -2684,8 +2711,7 @@ recursive subroutine trav_assign_define_list(coder,cblock,pnode,node) assn=node_arg(node,i) lhs=node_arg(assn,1) sym=node_sym(lhs) - n=node_numargs(lhs) - if(sym/=sym_assign) n=n-2 + n=lhs_size(lhs) rhs=node_arg(assn,2) call trav_rhs(coder,cblock,node,rhs,n) enddo @@ -2703,19 +2729,26 @@ end subroutine trav_assign_define_list ! Computes these in *reverse* order assuming RHS has ! stacked them one after the other. !======================================================== - subroutine trav_lhs(coder,cblock,node,lhs,rhs) + recursive subroutine trav_lhs(coder,cblock,node,lhs,rhs) type(code_state):: coder type(pm_ptr),intent(in):: cblock,node,lhs,rhs integer:: i,n,sym - type(pm_ptr):: rhs_val + type(pm_ptr):: lhs_val,rhs_val n=node_numargs(lhs) sym=node_sym(lhs) select case(sym) case(sym_var,sym_const) do i=n-2,1,-1 - call make_definition(coder,cblock,lhs,node_arg(lhs,i),& - merge(0,var_is_var,sym==sym_const),node_arg(lhs,n),& - node_num_arg(lhs,n-1)) + lhs_val=node_arg(lhs,i) + if(node_sym(lhs_val)==sym_dotdotdot) then + call make_definition(coder,cblock,lhs,node_arg(lhs_val,1),& + merge(0,var_is_var,sym==sym_const),node_arg(lhs,n),& + node_num_arg(lhs,n-1)) + else + call make_definition(coder,cblock,lhs,lhs_val,& + merge(0,var_is_var,sym==sym_const),node_arg(lhs,n),& + node_num_arg(lhs,n-1)) + endif enddo case(sym_where) do i=n,1,-1 @@ -2730,6 +2763,10 @@ subroutine trav_lhs(coder,cblock,node,lhs,rhs) do i=n,1,-1 call trav_single_lhs(coder,cblock,lhs,node_arg(lhs,i),rhs_val) enddo + case(sym_assign_list) + do i=n,1,-1 + call trav_lhs(coder,cblock,lhs,node_arg(lhs,i),rhs) + enddo end select end subroutine trav_lhs @@ -2912,7 +2949,7 @@ subroutine assign_call(pnode,simple) else call swap_code(coder) call make_assign_call(coder,cblock,pnode,& - merge(sym_aliased_assign,sym_assignment,present(alias)),& + merge(sym_aliased_assign,sym_pm_assign,present(alias)),& 2,0,aflags=call_is_assign_call) endif end subroutine assign_call @@ -2933,7 +2970,7 @@ recursive subroutine make_op_assignment_noalias(coder,cblock,pnode,node,op) call trav_reference(coder,cblock,pnode,node,.true.,.true.,.false.) call swap_code(coder) call trav_expr(coder,cblock,pnode,op) - call make_assign_call(coder,cblock,pnode,sym_assignment,3,0) + call make_assign_call(coder,cblock,pnode,sym_pm_assign,3,0) end subroutine make_op_assignment_noalias !=================================================================== @@ -3103,7 +3140,7 @@ subroutine make_var_assignment(coder,cblock,node,var,aflags) if(cnode_flags_set(v,var_flags,var_is_ref)) then call make_assign_call(coder,cblock,node,sym_set_ref,2,0,aflags=flags) else - call make_assign_call(coder,cblock,node,sym_assignment,2,0,aflags=flags) + call make_assign_call(coder,cblock,node,sym_pm_assign,2,0,aflags=flags) endif call access_var(coder,v,.true.) end subroutine make_var_assignment diff --git a/src/infer.f90 b/src/infer.f90 index 2aece0c..3057da3 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -1191,7 +1191,7 @@ subroutine inf_call(coder,cblock,callnode) 'Cannot initialise constant twice in succession: ',& cnode_get(cnode_arg(args,1),var_name)) endif - case(sym_assignment) + case(sym_pm_assign) tno=pm_type_get_mode(coder%context,arg_type_with_mode(1)) if(tno>=sym_invar) then call inf_error(coder,callnode,& @@ -3610,7 +3610,7 @@ function hide(node) result(hideit) return endif name=pm_name_stem(coder%context,sig_name(coder,cnode_get_num(node,call_sig))) - if(name==sym_assignment.or.name==sym_assign_var.or.& + if(name==sym_pm_assign.or.name==sym_assign_var.or.& name==sym_make_subref.or.name==sym_make_sublhs.or.& name==sym_make_sublhs_amp) then hideit=.false. @@ -3669,7 +3669,7 @@ subroutine print_call_details(coder,node,base,numargs) if(signame==sym_proc) then tv=pm_type_vect(coder%context,coder%wstack(base)) signame=abs(pm_tv_name(tv)) - elseif(signamebase==sym_assignment.or.signamebase==sym_assign_var) then + elseif(signamebase==sym_pm_assign.or.signamebase==sym_assign_var) then signame=sym_assign elseif(signamebase==sym_make_subref.or.signamebase==sym_make_sublhs.or.& signamebase==sym_make_sublhs_amp) then diff --git a/src/parser.f90 b/src/parser.f90 index e307983..b50d41a 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1412,15 +1412,20 @@ end subroutine set_flags end function call_attr - !====================================================== + !============================================================ ! Qualifiers - ! .name [ ] - !====================================================== - recursive function qual(parser,dot_call) result(iserr) + ! .name .digit .{} [] .name() .{}() .() .'() .%() + ! Will immediately return true in dot_call if this is present + ! and just encountered a .() or .'() or .%() call + ! Will return true in last_is_method if this present + ! and qualifier finishes on a .name() or .{}() method call + !============================================================ + recursive function qual(parser,dot_call,last_is_method) result(iserr) type(parse_state),intent(inout):: parser - logical,intent(inout),optional:: dot_call + logical,intent(inout),optional:: dot_call,last_is_method logical:: iserr integer:: sym,line,pos,n + logical:: finish_on_method iserr=.true. n=1 if(parser%sym==sym_pling) then @@ -1432,6 +1437,7 @@ recursive function qual(parser,dot_call) result(iserr) call make_node(parser,sym_at,0) n=n+1 endif + finish_on_method=.false. do select case(parser%sym) case(sym_dot) @@ -1447,6 +1453,7 @@ recursive function qual(parser,dot_call) result(iserr) iserr=.false. return endif + n=1 case(sym_open_brace) call scan(parser) if(expr(parser)) return @@ -1456,8 +1463,10 @@ recursive function qual(parser,dot_call) result(iserr) if(exprlist(parser,sym=sym_pm_list)) return if(expect(parser,sym_close)) return call make_node_at(parser,sym_open,2,line,pos) + finish_on_method=.true. else call make_node_at(parser,sym_open_brace,1,line,pos) + finish_on_method=.false. endif n=n+1 case default @@ -1471,14 +1480,17 @@ recursive function qual(parser,dot_call) result(iserr) if(exprlist(parser,sym=sym_pm_list)) return call make_node(parser,sym_open,2) if(expect(parser,sym_close)) return + finish_on_method=.true. elseif(sym==sym_open) then call make_node(parser,sym_proc,1) call scan(parser) if(exprlist(parser,sym=sym_pm_list)) return call make_node(parser,sym_open,2) if(expect(parser,sym_close)) return + finish_on_method=.true. else call make_node_at(parser,sym_dot,1,line,pos) + finish_on_method=.false. endif n=n+1 end select @@ -1487,6 +1499,7 @@ recursive function qual(parser,dot_call) result(iserr) call push_sym_val(parser,parser%sym) call make_node_at(parser,sym_dot,1,line,pos) call scan(parser) + finish_on_method=.false. n=n+1 case(sym_open_square) call get_sym_pos(parser,line,pos) @@ -1494,12 +1507,14 @@ recursive function qual(parser,dot_call) result(iserr) if(subscript(parser)) return call simple_call(parser) call make_node_at(parser,sym_sub,1,line,pos) + finish_on_method=.false. n=n+1 case default if(n>1) call make_node(parser,sym_reference,n) exit end select enddo + if(present(last_is_method)) last_is_method=finish_on_method iserr=.false. end function qual @@ -2282,21 +2297,22 @@ end function sexpr end function subscript - !====================================================== - ! Assignment/definition: lhs, lhs... "=" rhs - ! or call with no return values - !====================================================== - recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr) + !============================================================= + ! Left hand side of an assignment or zero return call + ! { ( name [ qual ] [op] | _ ) ,} + ! Returns number of elements, number of underscores + ! is_call if just a call + ! cannot_be_move if operators present + !============================================================== + function lhs(parser,n,nu,is_call,cannot_be_move,last_is_method) result(iserr) type(parse_state),intent(inout):: parser - logical,intent(in):: call_ok,assign_ok,define_ok + integer,intent(out):: n,nu + logical,intent(inout),optional:: is_call,cannot_be_move,last_is_method logical:: iserr - integer:: n,nu,name,sym - logical:: dotcall,must_be_assignment,cannot_be_move + logical:: dotcall iserr=.true. n=0 nu=0 - must_be_assignment=.false. - cannot_be_move=.false. ! ( name [ qual ] | _ )* do @@ -2318,7 +2334,7 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr if(expect_name(parser)) return call make_node(parser,sym_use,2) endif - if(n>1.or.nu>0.or..not.call_ok) then + if(n>1.or.nu>0.or..not.present(is_call)) then call parse_error(parser,& 'Unexpected symbol in what seems to be a left hand side expression') return @@ -2329,20 +2345,21 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr call parse_error(parser,'Cannot follow a call with a comma') return endif + is_call=.true. iserr=.false. return case(sym_dot,sym_d1:sym_d7,sym_open_square,sym_at,sym_pling) - must_be_assignment=.true. dotcall=.false. call make_node(parser,sym_name,1) - if(qual(parser,dotcall)) return + if(qual(parser,dotcall,last_is_method)) return if(dotcall) then - if(n==1.and.call_ok) then + if(n==1.and.present(is_call)) then call make_node(parser,sym_do,1) if(parser%sym==sym_comma) then call parse_error(parser,'Cannot follow a call with a comma') return endif + is_call=.true. iserr=.false. return else @@ -2360,37 +2377,60 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr call make_node(parser,sym_proc,1) call make_node(parser,sym_lt,2) call scan(parser) - must_be_assignment=.true. - cannot_be_move=.true. + if(present(cannot_be_move)) cannot_be_move=.true. case(sym_open_brace) call scan(parser) if(expr(parser)) return if(expect(parser,sym_close_brace)) return call make_node(parser,sym_lt,2) - must_be_assignment=.true. - cannot_be_move=.true. + if(present(cannot_be_move)) cannot_be_move=.true. end select if(parser%sym/=sym_comma) exit call scan(parser) enddo + iserr=.false. + end function lhs + !====================================================== + ! Assignment/definition: lhs, lhs... "=" rhs + ! or call with no return values + !====================================================== + recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr) + type(parse_state),intent(inout):: parser + logical,intent(in):: call_ok,assign_ok,define_ok + logical:: iserr + integer:: n,nu,name,sym + logical:: dotcall,cannot_be_move,last_is_method + iserr=.true. + + dotcall=.false. + cannot_be_move=.false. + last_is_method=.false. + if(lhs(parser,n,nu,dotcall,cannot_be_move,last_is_method)) return + + if(dotcall) then + iserr=.false. + return + endif + sym=parser%sym if(sym==sym_move.or.sym==sym_move_all.or.sym==sym_swap) then if(n/=1) then - call parse_error(parser,'Cannot have multiple left hand sides before "'//trim(sym_names(sym))//'"') + call parse_error(parser,'Cannot have multiple left hand sides before "'//& + trim(sym_names(sym))//'"') + elseif(nu>0) then + call parse_error(parser,'Cannot have "_" as the left hand side of "'//& + trim(sym_names(sym))//'"') elseif(cannot_be_move) then - call parse_error(parser,'Cannot have operators before "'//trim(sym_names(sym))//'"') + call parse_error(parser,'Cannot have operators before "'//& + trim(sym_names(sym))//'"') endif call scan(parser) if(valref(parser)) return call make_node(parser,sym,2) - else + elseif(parser%sym==sym_assign.or.n>1.or..not.last_is_method) then call make_node(parser,sym_assign,n) if(expect(parser,sym_assign)) return - - if(must_be_assignment.and..not.assign_ok) then - call parse_error(parser,'Cannot have an assignment in this context') - endif if(rhs(parser,n)) return call make_node(parser,sym_assign,2) endif @@ -2784,98 +2824,107 @@ recursive function if_stmt(parser) result(iserr) end function if_stmt !============================================================== - ! (var | const) { name | _ } [ : type ] [ = expr ] + ! { (var | let | assign ) { name | _ } [ : type ] , } [ = expr ] !============================================================== - recursive function var_stmt(parser,mode) result(iserr) + recursive function var_stmt(parser) result(iserr) type(parse_state),intent(inout):: parser - integer,intent(in),optional:: mode logical:: iserr - integer:: n,nu,ne,sym - logical:: dotcall + integer:: n,nu,m,vsym,mode + logical:: dotcall,has_dotdotdot iserr=.true. - sym=parser%sym - call scan(parser) - n=0 - nu=0 - ne=0 + mode=0 + m=0 do - if(parser%sym==sym_underscore) then + select case(parser%sym) + case(sym_var,sym_const) + vsym=parser%sym call scan(parser) - call make_node(parser,sym_underscore,0) - nu=nu+1 - else - if(expect_name(parser)) return - endif - n=n+1 - if(parser%sym==sym_comma) then + case(sym_invar,sym_nhd,sym_chan,sym_shared) + mode=parser%sym call scan(parser) - else - exit - endif - enddo - if(parser%sym==sym_colon) then - call scan(parser) - if(present(mode)) then + if(expect(parser,sym_var)) return + vsym=sym_var + case(sym_assignment) + call scan(parser) + if(lhs(parser,n,nu)) return + call make_node(parser,sym_assign,n) + goto 10 + case default + call parse_error(parser,'Expected "var", "let" or "assign"') + return + end select + n=0 + nu=0 + has_dotdotdot=.false. + do + if(parser%sym==sym_underscore) then + call scan(parser) + call make_node(parser,sym_underscore,0) + nu=nu+1 + elseif(parser%sym==sym_dotdotdot) then + call scan(parser) + if(expect_name(parser)) return + call make_node(parser,sym_dotdotdot,1) + has_dotdotdot=.true. + else + if(expect_name(parser)) return + endif + n=n+1 + if(parser%sym==sym_comma) then + call scan(parser) + if(parser%sym/=sym_underscore.and.parser%sym<=num_sym) then + call push_back(parser,sym_comma) + exit + endif + else + exit + endif + enddo + if(mode/=0) then call push_sym_val(parser,mode) else call push_null_val(parser) endif - if(typ(parser)) return - else - if(present(mode)) then - call push_sym_val(parser,mode) + if(parser%sym==sym_colon) then + if(has_dotdotdot) then + call parse_error(parser,& + 'Cannot give a new type to an object being initialised with "..."') + endif + call scan(parser) + if(typ(parser)) return else call push_null_val(parser) endif - call push_null_val(parser) - endif - call make_node(parser,sym,n+2) - if(ne==n) then - call parse_error(parser,& - 'A "'//trim(sym_names(sym))//& - '" statement must define at least one object') - endif - if(parser%sym==sym_assign) then + call make_node(parser,vsym,n+2) + if(nu==n.and.vsym/=sym_assignment) then + call parse_error(parser,& + 'A "'//trim(sym_names(vsym))//& + '" clause must define at least one object') + endif +10 continue + m=m+1 + if(parser%sym/=sym_comma) exit call scan(parser) + enddo + if(m>1) call make_node(parser,sym_assign_list,m) + + if(parser%sym/=sym_dotdotdot) then + if(expect(parser,sym_assign)) return if(rhs(parser,n)) return call make_node(parser,sym_assign,2) if(subexpr(parser)) return - elseif(present(mode)) then + elseif(m>1) then + call parse_error(parser,'Cannot have multiple left hand side elements before "..."') + elseif(mode/=0) then call parse_error(parser,'"'//trim(sym_names(mode))//' var" must have an initialiser') - elseif(nu+ne>0) then + elseif(nu>0) then call parse_error(parser,'Cannot have "_" in unitialised "'//& - trim(sym_names(sym))//'" declaration') - endif - iserr=.false. - end function var_stmt - - !============================================================== - ! ( shrd | invar | chan ) block - ! ( shrd | invar | nhd | chan ) var ... - !============================================================== - recursive function mode_stmt(parser) result(iserr) - type(parse_state),intent(inout):: parser - logical:: iserr - integer:: line,sym - iserr=.true. - line=get_sym_line(parser) - sym=parser%sym - call scan(parser) - if(parser%sym==sym_var) then - if(var_stmt(parser,sym)) return + trim(sym_names(vsym))//'" declaration') else - if(sym==sym_nhd) then - if(expect(parser,sym_var)) return - else - if(par_attr(parser,sym_distr,sym_block,sym)) return - call push_null_val(parser) - if(subexpr(parser)) return - if(block_or_single_stmt(parser,sym,0,line)) return - call make_node(parser,sym,3) - endif + call scan(parser) endif iserr=.false. - end function mode_stmt + end function var_stmt !========================================================== ! all ref [ op ] = expr [ subexpr ] @@ -3390,11 +3439,9 @@ recursive subroutine stmt_list(parser,single) case(sym_underscore) if(assn_or_call(parser,.false.,.true.,.true.)) goto 999 if(subexpr(parser)) goto 999 - case(sym_var,sym_const) + case(sym_var,sym_const,sym_invar,sym_chan,sym_nhd,sym_shared) if(var_stmt(parser)) goto 999 if(subexpr(parser)) goto 999 - case(sym_invar,sym_chan,sym_nhd,sym_shared) - if(mode_stmt(parser)) goto 999 case(sym_dollar) if(proc_val_call()) goto 999 case(sym_sync) diff --git a/src/symbol.f90 b/src/symbol.f90 index 6381f47..34bb8da 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -191,7 +191,7 @@ module pm_symbol integer,parameter:: sym_test = last_decl + 18 integer,parameter:: sym_default = last_decl + 19 integer,parameter:: sym_task = last_decl + 20 - integer,parameter:: sym_extern = last_decl + 21 + integer,parameter:: sym_assignment = last_decl + 21 integer,parameter:: sym_var = last_decl + 22 integer,parameter:: sym_const = last_decl + 23 integer,parameter:: sym_each = last_decl + 24 @@ -416,7 +416,7 @@ module pm_symbol integer,parameter:: sym_d7= hook1 + 7 integer,parameter:: sym_copy_in = hook1 + 8 integer,parameter:: sym_copy_out = hook1 + 9 - integer,parameter:: sym_assignment = hook1 + 10 + integer,parameter:: sym_pm_assign = hook1 + 10 integer,parameter:: sym_aliased_assign = hook1 + 11 integer,parameter:: sym_first = hook1 + 12 integer,parameter:: sym_next = hook1 + 13 @@ -670,9 +670,9 @@ module pm_symbol data sym_names(sym_test) /'test'/ data sym_names(sym_default) /'default'/ data sym_names(sym_task) /'task'/ - data sym_names(sym_extern) /'extern'/ + data sym_names(sym_assignment) /'assign'/ data sym_names(sym_var) /'var'/ - data sym_names(sym_const) /'const'/ + data sym_names(sym_const) /'let'/ data sym_names(sym_each) /'foreach'/ data sym_names(sym_where) /'where'/ data sym_names(sym_split) /'split'/ @@ -888,7 +888,7 @@ module pm_symbol data sym_names(sym_copy_in) /'PM__copy_in'/ data sym_names(sym_copy_out) /'PM__copy_out'/ - data sym_names(sym_assignment) /'PM__assign'/ + data sym_names(sym_pm_assign) /'PM__assign'/ data sym_names(sym_aliased_assign) /'PM__aliased_assign'/ data sym_names(sym_first) /'PM__first'/ data sym_names(sym_next) /'PM__next'/ diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 8057892..bd21810 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -1448,7 +1448,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) enddo endif case(sym_private,sym_set_mode,sym_const,sym_var,& - sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_assignment) + sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_pm_assign) continue ! Nothing to do case(sym_null) call wc_call_args(wcd,callnode,args,op_nullify,0,nargs,nargs,rv,ve) From f95cb61f51be00f13f27c58d4e0e9d345d3592c6 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Tue, 13 May 2025 16:56:31 +0100 Subject: [PATCH 18/36] Multiple LHS --- pm/lib/sys/pm.pmm | 7 ++- src/codegen.f90 | 85 +++++++++++++++++++++++------- src/infer.f90 | 46 ++++++++-------- src/parser.f90 | 131 +++++++++++++++++++++++++++------------------- src/symbol.f90 | 10 ++-- src/wcoder.f90 | 2 +- 6 files changed, 184 insertions(+), 97 deletions(-) diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm index c9259b2..0d06180 100644 --- a/pm/lib/sys/pm.pmm +++ b/pm/lib/sys/pm.pmm @@ -1700,7 +1700,12 @@ PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" PM__intrinsic PM__make_const(x:any)->(=x) : "clone_var" - +proc PM__init_var(x:any,y:any)=PM__make_var(x,y) +proc PM__init_const(x:any,y:any)=PM__make_const(x,y) +proc PM__init_var'(x:any,y:any)=PM__make_var'(x,y) +proc PM__init_const'(x:any,y:any)=PM__make_const'(x,y) +proc PM__make_var(x,y)=PM__make_var(x as y) +proc PM__make_const(x,y)=PM__make_const(x as y) PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" /* PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" diff --git a/src/codegen.f90 b/src/codegen.f90 index 5a223c6..888a685 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -1412,26 +1412,47 @@ end subroutine code_name_as_string recursive subroutine trav_sync_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - integer:: save_par_state + integer:: save_par_state,base + type(pm_ptr):: label,body + label=node_arg(node,1) + body=node_arg(node,2) select case(coder%par_state) case(par_state_none) call code_error(coder,node,& 'Cannot have a "sync" statement outside of a parallel context') - case(par_state_for,par_state_comm_proc) - call code_error(coder,node,& - 'Can only have "sync" statements inside a branch of a conditional statement') - case(par_state_sync) - call code_error(coder,node,& - 'Cannot nest "sync" or "sync while" statements inside each other') + case(par_state_for,par_state_comm_proc,par_state_sync) + if(.not.pm_fast_isnull(label)) then + call code_error(coder,node,& + 'Can only have "sync(...)" statements inside a branch of a conditional statement') + endif end select save_par_state=coder%par_state coder%par_state=par_state_sync - call code_val(coder,node_arg(node,1)) - call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_sync,open_scope=.true.) - call make_sp_call(coder,cblock,node,sym_sync,2,0) + + sym=node_sym(body) + if(sym==sym_open) then + call trav_call(coder,cblock,node,body,0,.true.) + elseif(sym==sym_assign) then + call trav_sync_assign(coder,cblock,node,body) + else + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_sync,open_scope=.true.) + endif + if(.not.pm_fast_isnull(parser)) then + call code_val(coder,label) + call make_sp_call(coder,cblock,node,sym_sync,2,0) + endif coder%par_state=save_par_state + contains + include 'fisnull.inc' end subroutine trav_sync_stmt + subroutine trav_sync_assign(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + + end subroutine trav_sync_assign + + !======================================================== ! Traverse "sync while" statement !======================================================== @@ -2327,7 +2348,7 @@ subroutine update_change_lists(coder,var,modify) integer:: lex_scope,lex_scope_of_var lex_scope=coder%lex_scope lex_scope_of_var=cnode_get_num(var,var_lex_scope) - do while(var_lex_scope1) then - call parse_error(parser,'Cannot have multiple left hand side elements before "..."') - elseif(mode/=0) then - call parse_error(parser,'"'//trim(sym_names(mode))//' var" must have an initialiser') - elseif(nu>0) then - call parse_error(parser,'Cannot have "_" in unitialised "'//& - trim(sym_names(vsym))//'" declaration') else + if(m>1) then + call parse_error(parser,'Cannot have multiple left hand side elements before "..."') + elseif(mode/=0) then + call parse_error(parser,'"'//trim(sym_names(mode))//' var" must have an initialiser') + elseif(nu>0) then + call parse_error(parser,'Cannot have "_" in unitialised "'//& + trim(sym_names(vsym))//'" declaration') + endif call scan(parser) endif iserr=.false. end function var_stmt - !========================================================== - ! all ref [ op ] = expr [ subexpr ] - !========================================================== - recursive function all_stmt(parser) result(iserr) - type(parse_state),intent(inout):: parser - logical:: iserr - iserr=.true. - call scan(parser) - if(valref(parser)) return - select case(parser%sym) - case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,& - sym_amp,sym_bar,sym_tilde,sym_concat) - call push_sym_val(parser,parser%sym) - call make_node(parser,sym_proc,1) - call scan(parser) - if(expect(parser,sym_assign)) return - case(sym_open_brace) - call scan(parser) - if(expr(parser)) return - if(expect(parser,sym_close_brace)) return - case(sym_assign) - call make_node(parser,sym_null,0) - case default - if(expect(parser,sym_assign)) return - end select - if(expr(parser)) return - call push_null_val(parser) - if(subexpr(parser)) return - call make_node(parser,sym_all,4) - iserr=.false. - end function all_stmt - + !========================================================== ! switch [ xexpr ] { case xexprlist : statement_list ... } !========================================================== @@ -3333,30 +3311,79 @@ function over_stmt(parser) result(iserr) end function over_stmt !====================================================== - ! sync [ while ] name [ block ] + ! sync ( [ while ] name) block | assignment | call !====================================================== function sync_stmt(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr - integer:: line,name + integer:: line,name,name2,sym,n,nu + logical:: is_call,is_assign,is_labelled iserr=.true. line=get_sym_line(parser) call scan(parser) + sym=sym_sync if(parser%sym==sym_open) then call scan(parser) - if(expect(parser,sym_while)) return + if(parser%sym==sym_while) then + call scan(parser) + sym=sym_sync_while + endif if(expect_and_get_name(parser,name)) return if(expect(parser,sym_close)) return + is_labelled=.true. + else + call push_null_val(parser) + is_labelled=.false. + endif + if(parser%sym==sym_colon.or.parser%sym==sym_open_brace) then + if(.not.is_labelled) then + call parse_error(parser,& + 'A "sync" statement that is not of the form "sync(...)"'//& + ' cannot be applied to a block of statements') + endif if(block_or_single_stmt(parser,sym_sync,name,line)) return - call make_node(parser,sym_sync_while,2) + call make_node(parser,sym,2) else - if(expect_and_get_name(parser,name)) return - if(parser%sym==sym_open_brace.or.parser%sym==sym_colon) then - if(block_or_single_stmt(parser,sym_sync,name,line)) return + if(parser%sym==sym_dollar) then + call scan(parser) + if(op(parser,name2,.true.,.false.)) return + call push_sym_val(parser,name2) + call make_node(parser,sym_proc,1) + if(parser%sym==sym_dot) call scan(parser) + if(arglist(parser)) return + call make_node(parser,sym_open,1) else - call push_null_val(parser) + if(parser%sym==sym_assignment) then + call scan(parser) + is_assign=.true. + else + is_assign=.false. + endif + is_call=.false. + if(lhs(parser,n,nu,is_call)) return + if(is_call) then + if(is_assign) then + call parse_error(parser,& + 'Left hand side of "sync assign" appears to contain a procedure call') + return + else + call make_node(parser,sym_open,1) + endif + elseif(n>1) then + call parse_error(parser,'"sync" assignment can only have one left hand side') + return + elseif(nu>1) then + call parse_error(parser,'Left hand side of "sync" assignment cannot be "_"') + return + else + if(expect(parser,sym_assign)) return + if(expr(parser)) return + call make_node(parser,sym_assign,2) + endif endif - call make_node(parser,sym_sync,2) + call push_null_val(parser) + if(subexpr(parser)) return + call make_node(parser,sym,3) endif iserr=.false. end function sync_stmt @@ -3432,14 +3459,12 @@ recursive subroutine stmt_list(parser,single) if(par_stmt(parser)) goto 999 case(sym_any) if(any_stmt(parser)) goto 999 - case(sym_all) - if(all_stmt(parser)) goto 999 case(sym_over) if(over_stmt(parser)) goto 999 case(sym_underscore) if(assn_or_call(parser,.false.,.true.,.true.)) goto 999 if(subexpr(parser)) goto 999 - case(sym_var,sym_const,sym_invar,sym_chan,sym_nhd,sym_shared) + case(sym_var,sym_const,sym_assignment,sym_invar,sym_chan,sym_nhd,sym_shared) if(var_stmt(parser)) goto 999 if(subexpr(parser)) goto 999 case(sym_dollar) diff --git a/src/symbol.f90 b/src/symbol.f90 index 34bb8da..a0a8730 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -405,7 +405,9 @@ module pm_symbol integer,parameter:: sym_lhs_and_val_sync = hook + 60 integer,parameter:: sym_iter_ref = hook + 61 integer,parameter:: sym_check_task = hook + 62 - integer,parameter:: hook1 = hook + 62 + integer,parameter:: sym_init_var = hook + 63 + integer,parameter:: sym_init_const = hook + 64 + integer,parameter:: hook1 = hook + 64 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -521,7 +523,7 @@ module pm_symbol integer,parameter:: sym_split_param = hook5 + 32 integer,parameter:: sym_dim_noinit = hook5 + 33 integer,parameter:: sym_pm_node = hook5 + 34 - integer,parameter:: sym_init_const = hook5 + 35 + integer,parameter:: sym_init_constx = hook5 + 35 integer,parameter:: sym_pm_dump = hook5 + 36 integer,parameter:: hook6 = 36 + hook5 @@ -877,6 +879,8 @@ module pm_symbol data sym_names(sym_lhs_and_val_sync) /'PM__lhs_and_val_sync'/ data sym_names(sym_iter_ref) /'PM__iter_ref'/ data sym_names(sym_check_task) /'PM__check_task'/ + data sym_names(sym_init_var) /'PM__init_var'/ + data sym_names(sym_init_const) /'PM__init_const'/ data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ @@ -991,7 +995,7 @@ module pm_symbol data sym_names(sym_get_chunk) /'chunk'/ data sym_names(sym_pm_atz) /'PM__atz'/ data sym_names(sym_pm_node) /'PM__node'/ - data sym_names(sym_init_const) /'PM__init_const'/ + data sym_names(sym_init_constx) /'PM__init_constx'/ data sym_names(sym_infer_stack) /'infer_stack'/ data sym_names(sym_infer_type) /'infer_type'/ diff --git a/src/wcoder.f90 b/src/wcoder.f90 index bd21810..5e1442f 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -1447,7 +1447,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) var_slot(wcd,cnode_arg(args,kk))) enddo endif - case(sym_private,sym_set_mode,sym_const,sym_var,& + case(sym_private,sym_set_mode,sym_const,sym_var,sym_dotdotdot,& sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_pm_assign) continue ! Nothing to do case(sym_null) From 532d911401fb771270ecddcc16f4613d943d704b Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Wed, 14 May 2025 21:07:59 +0100 Subject: [PATCH 19/36] Assignments --- src/codegen.f90 | 981 +++++++++++++++++++----------------------------- src/parser.f90 | 6 +- src/symbol.f90 | 50 +-- 3 files changed, 411 insertions(+), 626 deletions(-) diff --git a/src/codegen.f90 b/src/codegen.f90 index 888a685..a3f4440 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -73,7 +73,6 @@ module pm_codegen integer,parameter:: par_state_masked=3 integer,parameter:: par_state_cond=4 integer,parameter:: par_state_par=5 - integer,parameter:: par_state_sync=6 ! Flags indicating start/end of a block of type variables ! as opposed to regular variables on variables stack @@ -526,8 +525,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_over_stmt(coder,cblock,list,node) case(sym_assign) call trav_assign_define(coder,cblock,list,node) - case(sym_assign_list) - call trav_assign_define_list(coder,cblock,list,node) case(sym_all) call trav_all_stmt(coder,cblock,list,node) case(sym_where,sym_split,sym_check,sym_amp) @@ -849,9 +846,11 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) call make_sys_call_rtn(coder,cblock2,node,sym_as,2,1) call hide_vars(coder,vb,vb) if(pm_fast_isnull(node_arg(node,2))) then - call make_assignment_noalias(coder,cblock2,node,node_arg(node,1)) + call trav_assign(coder,cblock2,node,node_arg(node,1),pm_null_obj,& + sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) else - call make_assignment_noalias(coder,cblock2,node,node_arg(node,2)) + call trav_assign(coder,cblock2,node,node_arg(node,2),pm_null_obj,& + sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) endif call reveal_vars(coder,vb,vb) endif @@ -1197,337 +1196,8 @@ recursive subroutine trav_all_stmt(coder,cblock,pnode,node) end subroutine trav_all_stmt - !================================================================ - ! Traverse a reference leaving an object or object reference - ! on vstack - ! If isalias is true then a second element on the stack is a - ! list of reference elements to be used in alias checking - !================================================================ - subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - logical,intent(in):: islhs,skipdot,isalias - integer,intent(out),optional:: call_n - type(pm_ptr):: arg - integer:: i,j,n,sym,start,base,vbase,abase,atop - logical:: iscomm,isvar - - sym=node_sym(node) - if(sym==sym_name) then - call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) - return - endif - arg=node_arg(node,1) - if(node_sym(arg)==sym_name) then - call trav_ref_to_var(coder,cblock,arg,node_num_arg(arg,1),islhs) - isvar=.true. - else - call trav_expr(coder,cblock,node,arg) - isvar=.false. - endif - - start=2 - arg=node_arg(node,start) - sym=node_sym(arg) - abase=coder%vtop - if(sym==sym_pling) then - call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_pling,1,1) - iscomm=.true. - start=3 - elseif(sym==sym_at) then - call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_at,1,merge(2,1,isalias)) - iscomm=.true. - start=3 - else - arg=top_code(coder) - if(cnode_get_kind(arg)==cnode_is_var) then - if(isvar) then - iscomm=cnode_flags_set(arg,var_flags,var_is_maybe_not_private) - else - iscomm=coder%par_state/=par_state_none - endif - else - iscomm=.false. - endif - endif - - vbase=coder%vtop - base=coder%vtop-start+2 - - n=node_numargs(node) - do i=start,n - arg=node_arg(node,i) - sym=node_sym(arg) - select case(sym) - case(sym_dot) - call code_name_as_string(coder,cblock,arg,node_num_arg(arg,1)) - case(sym_open_brace) - call trav_expr(coder,cblock,arg,node_arg(arg,1)) - call make_sp_call(coder,cblock,arg,sym_open_brace,1,0,flags=call_is_no_touch) - case(sym_sub) - call trav_expr(coder,cblock,arg,node_arg(arg,1)) - case(sym_open) - call trav_expr(coder,cblock,arg,node_arg(arg,1)) - call trav_expr(coder,cblock,arg,node_arg(arg,2)) - call make_sp_call_rtn(coder,cblock,node,sym_list,2,1) - end select - enddo - - atop=coder%vtop - - call code_val(coder,coder%vstack(vbase)) - - i=start - - if(skipdot) then - arg=node_arg(node,i) - sym=node_sym(arg) - do while(sym==sym_dot.or.sym==sym_open_brace) - call code_val(coder,coder%vstack(base+i)) - call make_sp_call_rtn(coder,cblock,arg,sym_dot,2,1) - i=i+1 - if(i>n) exit - arg=node_arg(node,i) - sym=node_sym(arg) - enddo - endif - - if(i=0) call hide_where_vars(coder,base+1,xtop) - - call make_block_proc(coder,cblock,node,& - pm_null_obj,& - int(coder%comm_amp%offset),pm_null_obj,0,& - node_arg(node,3)) - call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) - call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) - call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) - call make_full_sys_call(coder,cblock,node,call_sym,3,0,& - coder%block_amp,keys,keynames,& - proccall_is_comm+proccall_is_general) - - coder%temp2=pm_null_obj - contains - include 'fisnull.inc' - end subroutine trav_mode_stmt !======================================================== @@ -2459,8 +2129,6 @@ recursive subroutine apply_x(nodep,node) select case(node_sym(node)) case(sym_assign) call trav_assign_define(coder,cblock,nodep,node) - case(sym_assign_list) - call trav_assign_define_list(coder,cblock,nodep,node) case(sym_list) call trav_exprlist(coder,cblock,nodep,node) case(sym_result) @@ -2677,13 +2345,55 @@ end subroutine code_check_invar !!$ !!$ end subroutine trav_par_stmt + !======================================================== + ! Traverse "sync" statement + !======================================================== + recursive subroutine trav_sync_stmt(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: save_par_state,base,sym + type(pm_ptr):: label,body + label=node_arg(node,1) + body=node_arg(node,2) + select case(coder%par_state) + case(par_state_none) + call code_error(coder,node,& + 'Cannot have a "sync" statement outside of a parallel context') + case(par_state_for,par_state_comm_proc,par_state_masked) + if(.not.pm_fast_isnull(label)) then + call code_error(coder,node,& + 'Can only have "sync(...)" statements inside a conditional statement'//& + ' with more than one none-empty branch') + endif + end select + save_par_state=coder%par_state + coder%par_state=par_state_masked + + sym=node_sym(body) + if(sym==sym_open) then + call trav_call(coder,cblock,node,body,0,.true.) + elseif(sym==sym_assign) then + call trav_assign(coder,cblock,node,node_arg(body,1),node_arg(body,2),& + sym_sync_assign,sym_sync_assign_op,sym_sync_assign_ref) + else + call trav_stmt_list(coder,cblock,node,body,sym_sync,open_scope=.true.) + endif + if(.not.pm_fast_isnull(label)) then + call code_val(coder,label) + call make_sp_call(coder,cblock,node,sym_sync,2,0) + endif + coder%par_state=save_par_state + contains + include 'fisnull.inc' + end subroutine trav_sync_stmt + !***************************************************** ! ASSIGNMENTS AND VARIABLE DEFINITIONS !***************************************************** - + !======================================================== - ! Traverse single assignment or var/const definition + ! Traverse assignments, var/const definitions !======================================================== recursive subroutine trav_assign_define(coder,cblock,pnode,node) type(code_state),intent(inout):: coder @@ -2695,11 +2405,86 @@ recursive subroutine trav_assign_define(coder,cblock,pnode,node) rhs=node_arg(node,2) sym=node_sym(lhs) n=lhs_size(lhs) - call trav_rhs(coder,cblock,node,rhs,n) - call trav_lhs(coder,cblock,node,lhs,rhs) + if(n==1.and.sym==sym_assign) then + call trav_assign(coder,cblock,node,node_arg(lhs,1),rhs,& + sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) + else + call trav_rhs(coder,cblock,node,rhs,n) + call trav_lhs(coder,cblock,node,lhs) + endif coder%vtop=base end subroutine trav_assign_define + !============================================================== + ! Traverse assignment giving: + ! $call_sym(var,expr,subs...) + ! $call_sym_op(var,op,expr,subs...) - for op= + ! $call_sym_ref(ref,ref) - for non-aliased refs + !============================================================== + subroutine trav_assign(coder,cblock,node,alhs,rhs,call_sym,& + call_sym_op,call_sym_ref) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,alhs,rhs + integer,intent(in):: call_sym,call_sym_op,call_sym_ref + integer:: base,n,is_op,sym + logical:: hard_alias + type(pm_ptr):: temp,lhs + + sym=node_sym(alhs) + if(sym==sym_open_brace) then + lhs=node_arg(alhs,1) + is_op=1 + else + lhs=alhs + is_op=0 + endif + + if(is_op==0.and..not.pm_fast_isnull(rhs)) then + if(node_sym(rhs)==sym_reference) then + if(is_aliased(lhs,rhs,hard_alias)) then + if(hard_alias) then + call code_error(coder,node,& + 'Left and right hand sides of assignment are identical') + return + endif + else + call trav_reference(coder,cblock,node,lhs,.true.,.false.,.false.) + call trav_reference(coder,cblock,node,rhs,.false.,.false.,.false.) + if(coder%par_state==par_state_none) then + call make_sys_call(coder,cblock,node,call_sym_ref,2,0,& + assign=.true.) + else + call make_comm_sys_call(coder,cblock,node,call_sym_ref,2,0,& + assign=.true.) + endif + return + endif + endif + endif + if(.not.pm_fast_isnull(rhs)) then + call trav_expr(coder,cblock,node,rhs) + endif + base=coder%vtop + if(is_op/=0) then + call trav_expr(coder,cblock,node,node_arg(alhs,1)) + endif + call trav_reference(coder,cblock,node,lhs,.true.,.true.,.false.,call_n=n) + ! Swap rhs-expr with lhs-variable in argument list + temp=coder%vstack(base) + coder%vstack(base)=coder%vstack(base+is_op+1) + coder%vstack(base+is_op+1)=temp + if(coder%par_state==par_state_none) then + call make_sys_call(coder,cblock,node,& + merge(call_sym_op,call_sym,is_op/=0),n+2+is_op,0,assign=.true.) + else + call make_comm_sys_call(coder,cblock,node,& + merge(call_sym_op,call_sym,is_op/=0),n+2+is_op,0,assign=.true.) + endif + contains + include 'fisnull.inc' + end subroutine trav_assign + + !======================================================== ! Number of elements in LHS node !======================================================== @@ -2719,40 +2504,14 @@ recursive function lhs_size(lhs) result(n) endif end function lhs_size - !======================================================== - ! Traverse multiple assignments, var/const definitions - !======================================================== - recursive subroutine trav_assign_define_list(coder,cblock,pnode,node) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - type(pm_ptr):: assn,lhs,rhs - integer:: i,n,sym,base - base=coder%vtop - do i=1,node_numargs(node) - assn=node_arg(node,i) - lhs=node_arg(assn,1) - sym=node_sym(lhs) - n=lhs_size(lhs) - rhs=node_arg(assn,2) - call trav_rhs(coder,cblock,node,rhs,n) - enddo - do i=node_numargs(node),1,-1 - assn=node_arg(node,i) - lhs=node_arg(assn,1) - rhs=node_arg(assn,2) - call trav_lhs(coder,cblock,node,lhs,rhs) - enddo - coder%vtop=base - end subroutine trav_assign_define_list - !======================================================== ! Traverse left hand side of assignment or definition ! Computes these in *reverse* order assuming RHS has ! stacked them one after the other. !======================================================== - recursive subroutine trav_lhs(coder,cblock,node,lhs,rhs) + recursive subroutine trav_lhs(coder,cblock,node,lhs) type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,lhs,rhs + type(pm_ptr),intent(in):: cblock,node,lhs integer:: i,n,sym type(pm_ptr):: lhs_val,rhs_val n=node_numargs(lhs) @@ -2776,52 +2535,17 @@ recursive subroutine trav_lhs(coder,cblock,node,lhs,rhs) call make_definition(coder,cblock,lhs,node_arg(lhs,i),var_is_where) enddo case(sym_assign) - if(node_sym(rhs)==sym_assign) then - rhs_val=node_arg(rhs,1) - else - rhs_val=rhs - endif do i=n,1,-1 - call trav_single_lhs(coder,cblock,lhs,node_arg(lhs,i),rhs_val) + call trav_assign(coder,cblock,lhs,node_arg(lhs,i),pm_null_obj,& + sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) enddo case(sym_assign_list) do i=n,1,-1 - call trav_lhs(coder,cblock,lhs,node_arg(lhs,i),rhs) + call trav_lhs(coder,cblock,lhs,node_arg(lhs,i)) enddo end select end subroutine trav_lhs - !============================================================= - ! Traverse single element of the left hand side of assignment - ! or definition (simple "=", not var or const) - !============================================================= - subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,lhs,rhs - type(pm_ptr):: var - integer:: name - if(pm_fast_isname(lhs)) then - name=lhs%offset - elseif(node_sym(lhs)==sym_name) then - name=node_num_arg(lhs,1) - elseif(node_sym(lhs)==sym_lt) then - call make_op_assignment_noalias(coder,cblock,lhs,node_arg(lhs,1),node_arg(lhs,2)) - return - else - call make_assignment(coder,cblock,node,lhs,rhs) - return - endif - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call make_definition(coder,cblock,node,lhs,0) - else - call make_assignment(coder,cblock,node,lhs,rhs,var) - endif - contains - include 'fisname.inc' - include 'fisnull.inc' - end subroutine trav_single_lhs - !======================================================== ! Traverse right hand side of assignment or definition ! which is required to produce n items @@ -2849,150 +2573,273 @@ subroutine trav_rhs(coder,cblock,node,rhs,n) do i=1,n call code_val(coder,coder%vstack(base+i)) enddo - call trav_call(coder,cblock,node,node_arg(rhs,3),n,.true.) - elseif(n>1) then - do i=1,n - call make_temp_var(coder,cblock,node) + call trav_call(coder,cblock,node,node_arg(rhs,3),n,.true.) + elseif(n>1) then + do i=1,n + call make_temp_var(coder,cblock,node) + enddo + do i=1,n + call code_val(coder,coder%vstack(base+i)) + enddo + call trav_call(coder,cblock,node,rhs,n,.true.) + else + call trav_top_expr(coder,cblock,node,rhs) + endif + end subroutine trav_rhs + + !================================================================ + ! Traverse a reference leaving an object or object reference + ! on vstack + ! If isalias is true then a second element on the stack is a + ! list of reference elements to be used in alias checking + !================================================================ + subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + logical,intent(in):: islhs,skipdot,isalias + integer,intent(out),optional:: call_n + type(pm_ptr):: arg + integer:: i,j,n,sym,start,base,vbase,abase,atop + logical:: iscomm,isvar + + sym=node_sym(node) + if(sym==sym_name) then + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) + return + endif + + arg=node_arg(node,1) + if(node_sym(arg)==sym_name) then + call trav_ref_to_var(coder,cblock,arg,node_num_arg(arg,1),islhs) + isvar=.true. + else + call trav_expr(coder,cblock,node,arg) + isvar=.false. + endif + + start=2 + arg=node_arg(node,start) + sym=node_sym(arg) + abase=coder%vtop + if(sym==sym_pling) then + call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_pling,1,1) + iscomm=.true. + start=3 + elseif(sym==sym_at) then + call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_at,1,merge(2,1,isalias)) + iscomm=.true. + start=3 + else + arg=top_code(coder) + if(cnode_get_kind(arg)==cnode_is_var) then + if(isvar) then + iscomm=cnode_flags_set(arg,var_flags,var_is_maybe_not_private) + else + iscomm=coder%par_state/=par_state_none + endif + else + iscomm=.false. + endif + endif + + vbase=coder%vtop + base=coder%vtop-start+2 + + n=node_numargs(node) + do i=start,n + arg=node_arg(node,i) + sym=node_sym(arg) + select case(sym) + case(sym_dot) + call code_name_as_string(coder,cblock,arg,node_num_arg(arg,1)) + case(sym_open_brace) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + call make_sp_call(coder,cblock,arg,sym_open_brace,1,0,flags=call_is_no_touch) + case(sym_sub) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + case(sym_open) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + call trav_expr(coder,cblock,arg,node_arg(arg,2)) + call make_sp_call_rtn(coder,cblock,node,sym_list,2,1) + end select + enddo + + atop=coder%vtop + + call code_val(coder,coder%vstack(vbase)) + + i=start + + if(skipdot) then + arg=node_arg(node,i) + sym=node_sym(arg) + do while(sym==sym_dot.or.sym==sym_open_brace) + call code_val(coder,coder%vstack(base+i)) + call make_sp_call_rtn(coder,cblock,arg,sym_dot,2,1) + i=i+1 + if(i>n) exit + arg=node_arg(node,i) + sym=node_sym(arg) + enddo + endif + + if(i : else: -!!$ lex_scope=push_lex_scope(coder) -!!$ call match_ref_pattern(coder,cblock,pnode,rbase,lbase,test=.true.) -!!$ coder%vstack(rbase+1)=coder%vstack(coder%vtop) -!!$ coder%vtop=rbase+1 -!!$ coder%lex_scope=lex_scope -!!$ cblock1=make_cblock(coder,cblock,pnode,sym_if) -!!$ call code_val(coder,coder%vstack(rbase)) -!!$ call make_assignment_noalias(coder,cblock1,pnode,lhs,avar,alias=.true.) -!!$ call close_cblock(coder,cblock1) -!!$ cblock2=make_cblock(coder,cblock,pnode,sym_if) -!!$ call code_val(coder,coder%vstack(rbase)) -!!$ call make_assignment_noalias(coder,cblock2,pnode,lhs,avar) -!!$ call close_cblock(coder,cblock2) -!!$ call get_lex_scope(coder,pnode) -!!$ call make_sp_call(coder,cblock,pnode,sym_if,4,0) -!!$ call pop_lex_scope(coder) -!!$ endif -!!$ else - call make_assignment_noalias(coder,cblock,pnode,lhs,avar) -!!$ endif - end subroutine make_assignment - - !============================================================ - ! Assign expression on top of stack to lhs in node - ! LHS must not alias RHS - ! (unless alias is present in which case LHS must alias RHS) - !============================================================ - recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node + subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode + integer,intent(in):: name + logical,intent(in):: islhs type(pm_ptr),intent(in),optional:: avar - logical,intent(in),optional:: alias - integer:: sym,outmode + type(pm_ptr):: var + integer:: flags,var_index if(present(avar)) then - call trav_ref_to_var(coder,cblock,pnode,0,.true.,avar) - call assign_call(pnode,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref)) - elseif(node_sym(node)==sym_underscore) then - call drop_code(coder) - return - elseif(pm_fast_isname(node)) then - call trav_ref_to_var(coder,cblock,pnode,int(node%offset),.true.) - call assign_call(pnode,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref)) + var=avar else - sym=node_sym(node) - select case(sym) - case(sym_reference) - call trav_reference(coder,cblock,pnode,node,.true.,.true.,.false.) - call assign_call(node,.false.) - case(sym_name) - call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),.true.) - call assign_call(node,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref)) - case default - !write(*,*) sym_names(sym) + var=find_var_and_entry(coder,name,var_index) + if(pm_fast_isnull(var)) then call code_error(coder,pnode,& - 'Cannot assign to expression') - call drop_code(coder) - end select + 'Variable or constant has not been defined: ',name) + call make_temp_var(coder,cblock,pnode) + return + endif + endif + + if(islhs) then + if(cnode_get_kind(var)==cnode_is_var) then + flags=cnode_get_num(var,var_flags) + if(iand(flags,var_is_var)==0.and..false.) then + call code_error(coder,pnode,& + 'Cannot assign to constant: ',name) + else + call access_var(coder,var,.true.) + endif + else + call code_error(coder,pnode,& + 'Cannot assign to constant: ',name) + endif + else + if(cnode_get_kind(var)==cnode_is_var) then + call access_var(coder,var,.false.) + endif endif + call code_val(coder,var) contains - include 'fisname.inc' include 'fisnull.inc' - include 'ftiny.inc' + end subroutine trav_ref_to_var + + function check_aliased(coder,node1,node2,str) result(aliased) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node1,node2 + character(len=*):: str + logical:: aliased + logical:: hard_aliased + aliased=is_aliased(node1,node2,hard_aliased) + if(hard_aliased) then + call code_error(coder,node1,str) + call code_error(coder,node2,'Corresponding variable access for the above error') + endif + end function check_aliased - subroutine assign_call(pnode,simple) - type(pm_ptr),intent(in):: pnode - logical,intent(in):: simple - integer:: call_sym - if(simple) then - call_sym=merge(sym_assign_or_init,sym_init_const,& - cnode_flags_set(top_code(coder),var_flags,var_is_var)) - call dup_code(coder) - call swap_code_2_1(coder) - call make_assign_call(coder,cblock,pnode,call_sym,2,1,& - aflags=call_takes_uninit+call_is_assign_call) - else - call swap_code(coder) - call make_assign_call(coder,cblock,pnode,& - merge(sym_aliased_assign,sym_pm_assign,present(alias)),& - 2,0,aflags=call_is_assign_call) - endif - end subroutine assign_call - - end subroutine make_assignment_noalias + function is_aliased(node1,node2,hard_aliased) result(aliased) + type(pm_ptr),intent(in):: node1,node2 + logical,intent(out),optional:: hard_aliased + logical:: aliased + integer:: i,start,ds1,ds2,sym1,sym2 + type(pm_ptr):: arg1,arg2 - !======================================================== - ! Assign expression on top of stack to lhs in node - !======================================================== - recursive subroutine make_op_assignment_noalias(coder,cblock,pnode,node,op) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node,op - integer:: n - if(node_sym(node)==sym_underscore) then - call drop_code(coder) + arg1=node_arg(node1,1) + sym1=node_sym(arg1) + arg2=node_arg(node2,1) + sym2=node_sym(arg2) + if(sym1/=sym_name.or.sym2/=sym_name) then + aliased=.false. + if(present(hard_aliased)) hard_aliased=.false. return + else + if(node_num_arg(arg1,1)/=node_num_arg(arg2,1)) then + aliased=.false. + if(present(hard_aliased)) hard_aliased=.false. + return + endif endif - call trav_reference(coder,cblock,pnode,node,.true.,.true.,.false.) - call swap_code(coder) - call trav_expr(coder,cblock,pnode,op) - call make_assign_call(coder,cblock,pnode,sym_pm_assign,3,0) - end subroutine make_op_assignment_noalias + + start=2 + sym1=node_sym(node_arg(node1,2)) + sym2=node_sym(node_arg(node2,2)) + if(sym1==sym_pling.or.sym2==sym_pling) then + if(sym1/=sym2) then + aliased=.true. + if(present(hard_aliased)) hard_aliased=.true. + return + endif + start=3 + endif + + ds1=merge(1,0,sym1==sym_at) + ds2=merge(1,0,sym2==sym_at) + + do i=start,min(node_numargs(node1),node_numargs(node2)) + arg1=node_arg(node1,i+ds1) + arg2=node_arg(node2,i+ds2) + if(node_sym(arg1)==sym_dot.and.node_sym(arg2)==sym_dot) then + if(node_num_arg(arg1,1)/=node_num_arg(arg2,1)) then + aliased=.false. + if(present(hard_aliased)) hard_aliased=.false. + return + endif + else + aliased=.true. + if(present(hard_aliased)) hard_aliased=.false. + return + endif + enddo + aliased=.true. + if(present(hard_aliased)) hard_aliased=.true. + end function is_aliased + + subroutine code_name_as_string(coder,cblock,node,name) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: name + call make_literal_const(coder,cblock,node,& + pm_new_literal_value_type(coder%context,& + pm_name_val(coder%context,name),name)) + end subroutine code_name_as_string !=================================================================== ! Use expression on top of stack to create new variable or constant @@ -3094,51 +2941,6 @@ recursive subroutine make_definition(coder,cblock,node,vname,flags,vtype,mode,do include 'ftiny.inc' end subroutine make_definition - !======================================================== - ! Reference to a variable - !======================================================== - subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode - integer,intent(in):: name - logical,intent(in):: islhs - type(pm_ptr),intent(in),optional:: avar - type(pm_ptr):: var - integer:: flags,var_index - if(present(avar)) then - var=avar - else - var=find_var_and_entry(coder,name,var_index) - if(pm_fast_isnull(var)) then - call code_error(coder,pnode,& - 'Variable or constant has not been defined: ',name) - call make_temp_var(coder,cblock,pnode) - return - endif - endif - - if(islhs) then - if(cnode_get_kind(var)==cnode_is_var) then - flags=cnode_get_num(var,var_flags) - if(iand(flags,var_is_var)==0.and..false.) then - call code_error(coder,pnode,& - 'Cannot assign to constant: ',name) - else - call access_var(coder,var,.true.) - endif - else - call code_error(coder,pnode,& - 'Cannot assign to constant: ',name) - endif - else - if(cnode_get_kind(var)==cnode_is_var) then - call access_var(coder,var,.false.) - endif - endif - call code_val(coder,var) - contains - include 'fisnull.inc' - end subroutine trav_ref_to_var !======================================================== ! Create a new system variable from expr on top of stack @@ -3169,31 +2971,6 @@ subroutine init_var(coder,cblock,node,var) 1,1) end subroutine init_var - !======================================================== - ! Assign top of stack to a given variable - !======================================================== - subroutine make_var_assignment(coder,cblock,node,var,aflags) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node - type(pm_ptr),intent(in)::var - integer,intent(in),optional:: aflags - type(pm_ptr):: v - integer:: flags - flags=call_ignore_rules - if(present(aflags)) then - flags=ior(flags,aflags) - endif - call code_val(coder,var) - v=var - call swap_code(coder) - if(cnode_flags_set(v,var_flags,var_is_ref)) then - call make_assign_call(coder,cblock,node,sym_set_ref,2,0,aflags=flags) - else - call make_assign_call(coder,cblock,node,sym_pm_assign,2,0,aflags=flags) - endif - call access_var(coder,v,.true.) - end subroutine make_var_assignment - !*************************************************** ! EXPRESSIONS diff --git a/src/parser.f90 b/src/parser.f90 index e709461..81d2a5c 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -2368,6 +2368,8 @@ function lhs(parser,n,nu,is_call,cannot_be_move,last_is_method) result(iserr) return endif endif + case default + call make_node(parser,sym_name,1) end select endif @@ -2375,14 +2377,14 @@ function lhs(parser,n,nu,is_call,cannot_be_move,last_is_method) result(iserr) case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_tilde,sym_concat) call push_sym_val(parser,parser%sym) call make_node(parser,sym_proc,1) - call make_node(parser,sym_lt,2) + call make_node(parser,sym_open_brace,2) call scan(parser) if(present(cannot_be_move)) cannot_be_move=.true. case(sym_open_brace) call scan(parser) if(expr(parser)) return if(expect(parser,sym_close_brace)) return - call make_node(parser,sym_lt,2) + call make_node(parser,sym_open_brace,2) if(present(cannot_be_move)) cannot_be_move=.true. end select if(parser%sym/=sym_comma) exit diff --git a/src/symbol.f90 b/src/symbol.f90 index a0a8730..751e486 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -332,16 +332,18 @@ module pm_symbol integer,parameter:: sym_dim = node0 + 41 integer,parameter:: sym_vdim = node0 + 42 integer,parameter:: sym_sync_assign = node0 + 43 - integer,parameter:: sym_get_filesystem = node0 + 44 - integer,parameter:: sym_nested_loop = node0 + 45 - integer,parameter:: sym_assign_list = node0 + 46 - integer,parameter:: sym_case_range = node0 + 47 - integer,parameter:: sym_dot_call = node0 + 48 - integer,parameter:: sym_key = node0 + 49 - integer,parameter:: sym_reference = node0 + 50 + integer,parameter:: sym_sync_assign_ref = node0 + 44 + integer,parameter:: sym_sync_assign_op = node0 + 45 + integer,parameter:: sym_get_filesystem = node0 + 46 + integer,parameter:: sym_nested_loop = node0 + 47 + integer,parameter:: sym_assign_list = node0 + 48 + integer,parameter:: sym_case_range = node0 + 49 + integer,parameter:: sym_dot_call = node0 + 50 + integer,parameter:: sym_key = node0 + 51 + integer,parameter:: sym_reference = node0 + 52 ! Misc. other symbols that need to be referenced by the compiler - integer,parameter:: hook = node0 + 51 + integer,parameter:: hook = node0 + 53 integer,parameter:: sym_pval_as = hook integer,parameter:: sym_pm_system = hook+1 integer,parameter:: sym_get_element = hook+2 @@ -419,18 +421,19 @@ module pm_symbol integer,parameter:: sym_copy_in = hook1 + 8 integer,parameter:: sym_copy_out = hook1 + 9 integer,parameter:: sym_pm_assign = hook1 + 10 - integer,parameter:: sym_aliased_assign = hook1 + 11 - integer,parameter:: sym_first = hook1 + 12 - integer,parameter:: sym_next = hook1 + 13 - integer,parameter:: sym_checkcase = hook1 + 14 - integer,parameter:: sym_dim1= hook1 + 15 - integer,parameter:: sym_dim2= hook1 + 16 - integer,parameter:: sym_dim3= hook1 + 17 - integer,parameter:: sym_dim4= hook1 + 18 - integer,parameter:: sym_dim5= hook1 + 19 - integer,parameter:: sym_dim6= hook1 + 20 - integer,parameter:: sym_dim7= hook1 + 21 - integer,parameter:: hook2= hook1+21 + integer,parameter:: sym_pm_assign_ref = hook1 + 11 + integer,parameter:: sym_pm_assign_op = hook1 +12 + integer,parameter:: sym_first = hook1 + 13 + integer,parameter:: sym_next = hook1 + 14 + integer,parameter:: sym_checkcase = hook1 + 15 + integer,parameter:: sym_dim1= hook1 + 16 + integer,parameter:: sym_dim2= hook1 + 17 + integer,parameter:: sym_dim3= hook1 + 18 + integer,parameter:: sym_dim4= hook1 + 19 + integer,parameter:: sym_dim5= hook1 + 20 + integer,parameter:: sym_dim6= hook1 + 21 + integer,parameter:: sym_dim7= hook1 + 22 + integer,parameter:: hook2= hook1+22 integer,parameter:: sym_generate = hook2 + 1 integer,parameter:: sym_broadcast = hook2 +2 @@ -803,7 +806,9 @@ module pm_symbol data sym_names(sym_cast) /'PM__cast'/ data sym_names(sym_dim) /'PM__dim'/ data sym_names(sym_vdim) /'PM__vdim'/ - data sym_names(sym_sync_assign) /''/ + data sym_names(sym_sync_assign) /'PM__sync_assign'/ + data sym_names(sym_sync_assign_ref) /'PM__sync_assign_ref'/ + data sym_names(sym_sync_assign_op) /'PM__sync_assign_op'/ data sym_names(sym_get_filesystem) /'PM__filesys'/ data sym_names(sym_nested_loop) /'PM__nested_loop'/ data sym_names(sym_assign_list) /''/ @@ -893,7 +898,8 @@ module pm_symbol data sym_names(sym_copy_in) /'PM__copy_in'/ data sym_names(sym_copy_out) /'PM__copy_out'/ data sym_names(sym_pm_assign) /'PM__assign'/ - data sym_names(sym_aliased_assign) /'PM__aliased_assign'/ + data sym_names(sym_pm_assign_ref) /'PM__assign_ref'/ + data sym_names(sym_pm_assign_op) /'PM__assign_op'/ data sym_names(sym_first) /'PM__first'/ data sym_names(sym_next) /'PM__next'/ data sym_names(sym_checkcase) /'PM__checkcase'/ From def2c30f0ff1a012624648ec584a528160049f2b Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 15 May 2025 15:35:17 +0100 Subject: [PATCH 20/36] Implementation of .{} --- src/cnodes.f90 | 9 ++++ src/codegen.f90 | 20 ++++---- src/infer.f90 | 127 ++++++++++++++++++++++++++++++------------------ src/parser.f90 | 5 +- src/types.f90 | 61 +++++++++++++++++++++-- src/wcoder.f90 | 2 +- 6 files changed, 162 insertions(+), 62 deletions(-) diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 5481134..1a59e85 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -254,6 +254,15 @@ function cnode_get_num(ptr,n) result(val) val=ptr%data%ptr(ptr%offset+n)%offset end function cnode_get_num + !============================================ + ! Module name for a cnode + !============================================ + function cnode_module_name(ptr) result(name) + type(pm_ptr),intent(in):: ptr + integer:: name + name=cnode_get_num(ptr,cnode_modl_name) + end function cnode_module_name + !============================================ ! Get argument n from cnode as a number !============================================ diff --git a/src/codegen.f90 b/src/codegen.f90 index a3f4440..2f0c04a 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -2643,7 +2643,7 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) endif vbase=coder%vtop - base=coder%vtop-start+2 + base=coder%vtop-start+1 n=node_numargs(node) do i=start,n @@ -2651,10 +2651,10 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) sym=node_sym(arg) select case(sym) case(sym_dot) - call code_name_as_string(coder,cblock,arg,node_num_arg(arg,1)) + call make_name_value(coder,cblock,arg,node_num_arg(arg,1)) case(sym_open_brace) call trav_expr(coder,cblock,arg,node_arg(arg,1)) - call make_sp_call(coder,cblock,arg,sym_open_brace,1,0,flags=call_is_no_touch) + call make_sp_call_rtn(coder,cblock,arg,sym_open_brace,1,1) case(sym_sub) call trav_expr(coder,cblock,arg,node_arg(arg,1)) case(sym_open) @@ -2675,7 +2675,7 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) sym=node_sym(arg) do while(sym==sym_dot.or.sym==sym_open_brace) call code_val(coder,coder%vstack(base+i)) - call make_sp_call_rtn(coder,cblock,arg,sym_dot,2,1) + call make_sp_call_rtn(coder,cblock,arg,merge(sym_dot_ref,sym_dot,islhs),2,1) i=i+1 if(i>n) exit arg=node_arg(node,i) @@ -2831,15 +2831,15 @@ function is_aliased(node1,node2,hard_aliased) result(aliased) aliased=.true. if(present(hard_aliased)) hard_aliased=.true. end function is_aliased - - subroutine code_name_as_string(coder,cblock,node,name) + + subroutine make_name_value(coder,cblock,node,name) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: name - call make_literal_const(coder,cblock,node,& - pm_new_literal_value_type(coder%context,& - pm_name_val(coder%context,name),name)) - end subroutine code_name_as_string + call make_const(coder,cblock,node,& + pm_name_val(coder%context,name),& + pm_new_name_type(coder%context,name)) + end subroutine make_name_value !=================================================================== ! Use expression on top of stack to create new variable or constant diff --git a/src/infer.f90 b/src/infer.f90 index 326ba2f..199253e 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -885,7 +885,7 @@ subroutine inf_call(coder,cblock,callnode) vbase_check=coder%vtop tbase_check=coder%wtop endif - + nret=cnode_get_num(callnode,call_nret) sig=-cnode_get_num(callnode,call_sig) args=cnode_get(callnode,call_args) @@ -1091,34 +1091,34 @@ subroutine inf_call(coder,cblock,callnode) if(tno2>0) then if(.not.pm_type_includes(coder%context,tno,tno2,& pm_type_incl_val)) then - call inf_error(coder,callnode,& - '"'//trim(sym_names(sig))//& - '" initial expression has wrong type for: ',& - pm_fast_name(coder%context,name)) - call inf_trace(coder) - tno2=error_type - endif - endif - tno2=pm_type_add_mode(coder%context,tno2,mode) - call combine_types(cnode_arg(args,1),tno2) - case(sym_pm_list) - call push_word(coder,pm_type_new_tuple+pm_type_is_list) - call push_word(coder,0) - do i=1,nargs - call push_word(coder,arg_type_with_mode(i+1)) - enddo - mode=pm_type_mix_modes(coder%context,& - coder%wstack(coder%wtop-nargs+1:coder%wtop)) - call make_type_if_possible(coder,nargs+2) - tno2=pop_word(coder) - tno2=pm_type_add_mode(coder%context,tno2,mode) - call combine_types(cnode_arg(args,1),tno2) - case(sym_dot,sym_dot_ref) - name=arg_type(3) - tno=arg_type_with_mode(2) - if(tno==error_type) then - call set_arg_to_error_type(1) - else + call inf_error(coder,callnode,& + '"'//trim(sym_names(sig))//& + '" initial expression has wrong type for: ',& + pm_fast_name(coder%context,name)) + call inf_trace(coder) + tno2=error_type + endif + endif + tno2=pm_type_add_mode(coder%context,tno2,mode) + call combine_types(cnode_arg(args,1),tno2) + case(sym_pm_list) + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + do i=1,nargs + call push_word(coder,arg_type_with_mode(i+1)) + enddo + mode=pm_type_mix_modes(coder%context,& + coder%wstack(coder%wtop-nargs+1:coder%wtop)) + call make_type_if_possible(coder,nargs+2) + tno2=pop_word(coder) + tno2=pm_type_add_mode(coder%context,tno2,mode) + call combine_types(cnode_arg(args,1),tno2) + case(sym_dot,sym_dot_ref) + name=arg_type(3) + tno=arg_type_with_mode(2) + if(tno==error_type.or.name==error_type) then + call set_arg_to_error_type(1) + else tno=pm_type_strip_mode(coder%context,& tno,mode) if(tno>0) then @@ -1130,7 +1130,42 @@ subroutine inf_call(coder,cblock,callnode) call set_arg_to_error_type(1) endif endif + case(sym_open_brace) + ! Used in .{ } + ! Check type is literal string or literal integer + ! Cater for literal string of the form "_name" + tno=arg_type(2) + if(tno>0) then + if(pm_type_kind(coder%context,tno)/=pm_type_is_single_name) then + tv=pm_type_vect(coder%context,arg_type(2)) + if(pm_tv_kind(tv)==pm_type_is_literal_value) then + tno2=pm_tv_arg(tv,1) + if(tno2==pm_string_type) then + tno=pm_name_type_from_literal_string(coder%context,tno,& + cnode_module_name(callnode)) + if(tno<0) then + call inf_error(coder,callnode,& + 'String value in ".{}" is not a valid name') + tno=error_type + endif + elseif(tno2/=pm_long) then + call inf_error(coder,callnode,& + 'Expression in ".{}" must be a literal string or integer') + tno=error_type + endif + else + call inf_error(coder,callnode,& + 'Expression in ".{}" must be a literal string or integer') + tno=error_type + endif + endif + endif + coder%stack(get_slot(1))=tno case(sym_dotdotdot) + ! Used in var ...x=y + ! Checks existing value of var + ! if it is an unintialised value type then convert to type-value + ! otherwise give an error tno=get_var_type(coder,callnode,cnode_arg(args,2),init=.true.) if(tno==error_type) then call set_arg_to_error_type(1) @@ -1345,7 +1380,7 @@ subroutine inf_call(coder,cblock,callnode) call pm_panic('inf_call') endif endif - + contains include 'ftypeof.inc' include 'fesize.inc' @@ -1442,7 +1477,7 @@ subroutine inf_any(nupdates) pm_type_add_mode(coder%context,tno,mode) call inf_cblock(coder,cnode_arg(args,2)) call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) - + if(i>1) then j=1 p=writelist @@ -1482,7 +1517,7 @@ subroutine inf_each_index() type(pm_ptr):: p,tv integer:: start,finish,tno,tno2,i,n,k,key(1) !!! need to handle modes - + p=cnode_arg(args,nret+3) p=cnode_arg(p,1) start=p%data%i(p%offset) @@ -1579,7 +1614,7 @@ function arg_type(m) result(tno) integer:: mode tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) end function arg_type - + !!$ !=================================================================== !!$ ! Return the type and mode for arguement m (no error check) !!$ !================================================================== @@ -1672,7 +1707,7 @@ subroutine check_logical(m,isinvar) endif end subroutine check_logical - + !================================================================== ! Set loop call signature to 1 if it is in a conditional ! (incling masked) context @@ -1690,7 +1725,7 @@ subroutine mark_loop_cond(m) endif call set_call_sig(mark) end subroutine mark_loop_cond - + !================================================================== ! Check if argument m has long type (int type in PM) !================================================================== @@ -1726,7 +1761,7 @@ subroutine check_loop_writes(arg) p=p%data%ptr(p%offset+1) enddo end subroutine check_loop_writes - + subroutine clear_cblock_mark(list) type(pm_ptr),intent(in):: list integer:: slot @@ -1793,21 +1828,19 @@ recursive function resolve_elem(var,tno,nametyp,isref,isopt,elem_type) result(si trim(pm_type_as_string(coder%context,tno))//'": ',& cnode_get(var,var_name)) else - sig=pm_type_find_elem(coder%context,tno,name,.false.,& + sig=pm_type_find_elem(coder%context,tno,nametyp,.false.,& elem_type) if(sig==0) then call inf_error_with_trace(coder,callnode,& - 'Type "'//trim(pm_type_as_string(coder%context,tno))//'"'//& - ' does not have an element named "'//& - trim(pm_name_as_string(coder%context,name))//'" in: ',& - cnode_get(var,var_name)) + 'An object of type "'//trim(pm_type_as_string(coder%context,tno))//'"'//& + ' does not have element "'//& + trim(pm_type_as_string(coder%context,nametyp))//'"') else call inf_error_with_trace(coder,callnode,& 'Cannot modify element "'//& - trim(pm_name_as_string(coder%context,name))//& + trim(pm_type_as_string(coder%context,nametyp))//& '" of type "'//& - trim(pm_type_as_string(coder%context,tno))//'" in: ',& - cnode_get(var,var_name)) + trim(pm_type_as_string(coder%context,tno))//'"') sig=0 endif endif @@ -1847,7 +1880,7 @@ subroutine combine_arg_types(m,typ,no_init) logical,intent(in),optional:: no_init call combine_types(cnode_arg(args,m),typ,no_init=no_init) end subroutine combine_arg_types - + !=================================================================== ! Augment the type stored in a given variable vararg by adding typ !================================================================== @@ -1857,8 +1890,8 @@ subroutine combine_types(vararg,typ,no_init) logical,intent(in),optional:: no_init call combine_var_type(coder,cblock,vararg,typ,no_init=no_init) end subroutine combine_types - - + + end subroutine inf_call !================================================================== diff --git a/src/parser.f90 b/src/parser.f90 index 81d2a5c..9e9cc0c 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1389,6 +1389,9 @@ recursive function call_attr(parser,iscall,flags) result(iserr) case(sym_keep_literals) !!! IS THIS TO BE USED? call set_flags(call_is_fixed) call scan(parser) + case(sym_pm_ref) + call set_flags(proccall_is_ref) + call scan(parser) end select if(parser%sym/=sym_comma) exit call scan(parser) @@ -1967,7 +1970,7 @@ recursive function term(parser,checkqual) result(iserr) if(expect(parser,sym_open)) return if(exprlist(parser,m,nolist=.true.)) return if(expect(parser,sym_close)) return - if(m/=3.and.m/=5) then + if(m/=3) then call parse_error(parser,'Wrong number of args to: '//sym_names(sym)) return endif diff --git a/src/types.f90 b/src/types.f90 index 8313ce6..17570a1 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -531,6 +531,46 @@ function pm_new_name_type(context,name) result(tno) tno=pm_new_type(context,args) end function pm_new_name_type + function pm_name_type_from_literal_string(context,tno,modname) result(tno2) + type(pm_context),pointer:: context + integer,intent(in):: tno,modname + integer:: tno2 + type(pm_ptr):: str + integer:: i,ic,name + character(len=1):: c + character(len=300):: strchars + str=pm_type_val(context,tno) + if(pm_debug_checks) then + if(pm_fast_vkind(str)/=pm_string) then + write(*,*) 'vkind=',pm_fast_vkind(str),pm_type_as_string(context,tno) + call pm_panic('Type to literal string') + endif + endif + do i=0,pm_fast_esize(str) + c=str%data%s(str%offset+i) + ic=iachar(c) + if(.not.(c=='_'.or.ic>=iachar('a').and.ic<=iachar('z').or.& + ic>=iachar('A').and.ic<=iachar('Z').or.& + i>0.and.ic>=iachar('0').and.ic<=iachar('9'))) then + tno2=-1 + return + endif + enddo + name=pm_type_name(context,tno) + if(str%data%s(str%offset)=='_') then + if(pm_fast_esize(str)<1) then + tno2=-1 + return + endif + strchars=pm_name_as_string(context,name) + name=pm_lname_entry(context,modname,trim(strchars(2:))) + endif + tno2=pm_new_name_type(context,name) + contains + include 'fesize.inc' + include 'fvkind.inc' + end function pm_name_type_from_literal_string + !========================================== ! Create new compile time value type !========================================== @@ -582,7 +622,7 @@ function pm_new_literal_value_type(context,val,vindex) result(tno) args(2)=pm_set_add(context,context%names,val) endif args(3)=pm_fast_typeof(val) - if(args(3)==pm_string) args(3)=pm_string_type + if(args(3)==pm_string.or.args(3)==pm_int32) args(3)=pm_string_type tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' @@ -2133,8 +2173,24 @@ recursive function pm_type_find_elem(context,tno,nametype,change,etype) result(o logical,intent(in):: change integer,intent(out):: etype integer:: offset,ptype,mode - type(pm_ptr):: tv + type(pm_ptr):: tv,nameval,names integer:: tk,i,name + if(pm_type_kind(context,nametype)==pm_type_is_literal_value) then + tv=pm_type_vect(context,tno) + if(pm_tv_kind(tv)==pm_type_is_rec) then + nameval=pm_type_val(context,nametype) + offset=nameval%data%ln(nameval%offset) + if(offset<=0.or.offset>pm_type_numargs(context,tno)) then + offset=0 + elseif(change) then + names=pm_name_val(context,pm_tv_name(tv)) + if(names%data%i(names%offset+offset)>0) offset=0 + endif + else + offset=0 + endif + return + endif name=pm_type_name(context,nametype) if(tno<0) then offset=0 @@ -2192,7 +2248,6 @@ subroutine pm_type_elem_offset(context,tv,name,change,offset,etyp) include 'fesize.inc' end subroutine pm_type_elem_offset - ! Concrete only version of a type (used/usable only for returns from builtin functions) recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result(tno2) type(pm_context),pointer:: context diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 5e1442f..1429a6f 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -1447,7 +1447,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) var_slot(wcd,cnode_arg(args,kk))) enddo endif - case(sym_private,sym_set_mode,sym_const,sym_var,sym_dotdotdot,& + case(sym_private,sym_set_mode,sym_const,sym_var,sym_dotdotdot,sym_open_brace,& sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_pm_assign) continue ! Nothing to do case(sym_null) From f7ebaebda1f852bc8156ccf4f289d3f9b5a6ed74 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 22 May 2025 12:52:51 +0100 Subject: [PATCH 21/36] Gates types --- pm/lib/sys/pm.pmm | 208 ++++++++++++++++++++------ src/codegen.f90 | 27 +++- src/infer.f90 | 2 +- src/main.f90 | 6 + src/opts.f90 | 5 + src/parser.f90 | 37 +++-- src/types.f90 | 369 ++++++++++++++++++++++++++++++++++++++++++---- 7 files changed, 567 insertions(+), 87 deletions(-) diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm index 0d06180..d92bff8 100644 --- a/pm/lib/sys/pm.pmm +++ b/pm/lib/sys/pm.pmm @@ -558,14 +558,11 @@ PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" PM__intrinsic im(cpx)->(real) : "imag_dc" PM__intrinsic conj(cpx)->(cpx) : "conj_dc" - - // Cannot convert real to int (must use nint or trunc) proc sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => fix(false) proc int(x:any_real)=0 :test "Cannot convert real to integer" => fix(false) proc lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => fix(false) - // Some numeric conversions not hard-coded proc cpx(x:real_num)=cpx(real(x)) proc scpx(x:real_num)=cpx(sreal(x)) @@ -715,16 +712,15 @@ type tuple4d(t1,t2,t3,t4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4} type tuple5d(t1,t2,t3,t4,t5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5} type tuple6d(t1,t2,t3,t4,t5,t6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6} type tuple7d(t1,t2,t3,t4,t5,t6,t7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7} -type tuple1d_of(t) is tuple1d(t) -type tuple2d_of(t) is tuple2d(t,t) -type tuple3d_of(t) is tuple3d(t,t,t) -type tuple4d_of(t) is tuple4d(t,t,t,t) -type tuple5d_of(t) is tuple5d(t,t,t,t,t) -type tuple6d_of(t) is tuple6d(t,t,t,t,t,t) -type tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t) -type tuple(t) is tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),tuple5d(t,t,t,t,t), - tuple6d(t,t,t,t,t,t),tuple7d(t,t,t,t,t,t,t) +type tuple(t,r:literal(int)) +type tuple(t,r:1) is ...,tuple1d(t) +type tuple(t,r:2) is ...,tuple2d(t,t) +type tuple(t,r:3) is ...,tuple3d(t,t,t) +type tuple(t,r:4) is ...,tuple4d(t,t,t,t) +type tuple(t,r:5) is ...,tuple5d(t,t,t,t,t) +type tuple(t,r:6) is ...,tuple6d(t,t,t,t,t,t) +type tuple(t,r:7) is ...,tuple7d(t,t,t,t,t,t,t) proc tuple(x)=rec tuple1d { PM__d1=x @@ -748,34 +744,34 @@ proc tuple(x,y,z,t,u,v,w)=rec tuple7d { PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w } -proc get_dim(t:tuple1d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple2d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple3d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple4d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple5d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple6d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple7d,n:fix(1) or [fix(1)])=t.1 -proc get_dim(t:tuple2d,n:fix(2) or [fix(2)])=t.2 -proc get_dim(t:tuple3d,n:fix(2) or [fix(2)])=t.2 -proc get_dim(t:tuple4d,n:fix(2) or [fix(2)])=t.2 -proc get_dim(t:tuple5d,n:fix(2) or [fix(2)])=t.2 -proc get_dim(t:tuple6d,n:fix(2) or [fix(2)])=t.2 -proc get_dim(t:tuple7d,n:fix(2) or [fix(2)])=t.2 -proc get_dim(t:tuple3d,n:fix(3) or [fix(3)])=t.3 -proc get_dim(t:tuple4d,n:fix(3) or [fix(3)])=t.3 -proc get_dim(t:tuple5d,n:fix(3) or [fix(3)])=t.3 -proc get_dim(t:tuple6d,n:fix(3) or [fix(3)])=t.3 -proc get_dim(t:tuple7d,n:fix(3) or [fix(3)])=t.3 -proc get_dim(t:tuple4d,n:fix(4) or [fix(4)])=t.4 -proc get_dim(t:tuple5d,n:fix(4) or [fix(4)])=t.4 -proc get_dim(t:tuple6d,n:fix(4) or [fix(4)])=t.4 -proc get_dim(t:tuple7d,n:fix(4) or [fix(4)])=t.4 -proc get_dim(t:tuple5d,n:fix(5) or [fix(5)])=t.5 -proc get_dim(t:tuple6d,n:fix(5) or [fix(5)])=t.5 -proc get_dim(t:tuple7d,n:fix(5) or [fix(5)])=t.5 -proc get_dim(t:tuple6d,n:fix(6) or [fix(6)])=t.6 -proc get_dim(t:tuple7d,n:fix(6) or [fix(6)])=t.6 -proc get_dim(t:tuple7d,n:fix(7) or [fix(7)])=t.7 +proc dim(t:tuple1d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple2d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple3d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple4d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple5d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple6d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple7d,n:fix(1) or [fix(1)])=t.1 +proc dim(t:tuple2d,n:fix(2) or [fix(2)])=t.2 +proc dim(t:tuple3d,n:fix(2) or [fix(2)])=t.2 +proc dim(t:tuple4d,n:fix(2) or [fix(2)])=t.2 +proc dim(t:tuple5d,n:fix(2) or [fix(2)])=t.2 +proc dim(t:tuple6d,n:fix(2) or [fix(2)])=t.2 +proc dim(t:tuple7d,n:fix(2) or [fix(2)])=t.2 +proc dim(t:tuple3d,n:fix(3) or [fix(3)])=t.3 +proc dim(t:tuple4d,n:fix(3) or [fix(3)])=t.3 +proc dim(t:tuple5d,n:fix(3) or [fix(3)])=t.3 +proc dim(t:tuple6d,n:fix(3) or [fix(3)])=t.3 +proc dim(t:tuple7d,n:fix(3) or [fix(3)])=t.3 +proc dim(t:tuple4d,n:fix(4) or [fix(4)])=t.4 +proc dim(t:tuple5d,n:fix(4) or [fix(4)])=t.4 +proc dim(t:tuple6d,n:fix(4) or [fix(4)])=t.4 +proc dim(t:tuple7d,n:fix(4) or [fix(4)])=t.4 +proc dim(t:tuple5d,n:fix(5) or [fix(5)])=t.5 +proc dim(t:tuple6d,n:fix(5) or [fix(5)])=t.5 +proc dim(t:tuple7d,n:fix(5) or [fix(5)])=t.5 +proc dim(t:tuple6d,n:fix(6) or [fix(6)])=t.6 +proc dim(t:tuple7d,n:fix(6) or [fix(6)])=t.6 +proc dim(t:tuple7d,n:fix(7) or [fix(7)])=t.7 proc indices(x:tuple1d)=[fix(1)] proc indices(x:tuple2d)=[fix(1),fix(2)] @@ -1035,7 +1031,6 @@ proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" - // ***************************************************** // RANGES AND SEQUENCES // ***************************************************** @@ -1446,8 +1441,9 @@ type iterable_dim is grid_slice_dim,cyclic_range,... type iterable_grid is tuple(iterable_dim),grid_slice proc _shp(x:iterable_dim)=0..size(x)-1 proc size(x:iterable_dim)->(int)... -proc element(x:iterable_dim,y)=error_type()check "Cannot index this type with a non-integer index"=>fix(false) -proc element(x:iterable_dim,y:int)->(any)... +proc element(x:iterable_dim,y)=error_type() + check "Cannot index this type with a non-integer index"=>fix(false) +proc element(x:iterable_dim,y:int)->(any)... proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) proc _shp(x:stretch_dim)=null proc _shp(x:null)=x @@ -1521,6 +1517,129 @@ proc expand(x:grid_slice,y:grid)=map($expand,x,y) proc contact(x:grid_slice,y:grid)=map($contract,x,y) PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" +// ************************************** +// ARRAYS +// ************************************** + +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) +type farray(e,d:shape) is e^let d,e^invar d,e^fix d,array_template(e,d,fix(false)) +type farray(e,d:mshape) is ..., + array_slice(e^let any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix any) + +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif + +PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(false))->(=x) : "array" +PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(true))->(=x) : "var_array" +PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(=x) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(=x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(=x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + +proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) +PM__intrinsic _make_subref(a:any^mshape,i:int)->(=a) : "make_rf" +PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" + +// Linear index of tuple mshape (zero base,unit stride) +proc _indx(g:null,s)=literal(0) +proc _indx(g:range(int),s)=int(s) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:null)=literal(1) +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _offset(x:mshape)=x._o +proc _offset(x)=literal(0) +proc _point2index(g:mshape1d or tuple(int,1),s:any_int)=int(_indx(g.1,s))+_offset(g) +proc _point2index(g:mshape1d or tuple(int,1),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g) +proc _point2index(g:mshape2d or tuple(int,2),s:tuple2d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2))+_offset(g) +proc _point2index(g:mshape3d or tuple(int,3),s:tuple3d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3)))+_offset(g) +proc _point2index(g:mshape4d or tuple(int,4),s:tuple4d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4))))+_offset(g) +proc _point2index(g:mshape5d or tuple(int,5),s:tuple5d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5)))))+_offset(g) +proc _point2index(g:mshape6d or tuple(int,6),s:tuple6d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6))))))+_offset(g) +proc _point2index(g:mshape7d or tuple(int,7),s:tuple7d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7))))))))+_offset(g) + +proc _index2point(i:int,s:range(int))=[i+s._lo] +proc _index2point(i:int,s:int)=[i] +proc _index2point(i:int,s:tuple(int,1))=[i] +proc _index2point(i:int,s:tuple(int,2))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,3))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,4))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,5))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,6))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,7))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) + + +/* +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} +*/ + +// ***************************************** +// ARRAY TEMPLATES +// ***************************************** +// Array templates +type array_template(a,d:mshape or dshape,v:fix(bool)) is rec {_a:a,_d:d,_s:int,_v:v} +proc array(a:any,s:dshape)=rec array_template { + _a=a,_d=s,_s=s._size,_v=fix(false) +} +proc array(a:any,s:mshape(tuple(range(int))))=rec array_template { + _a=a,_d=s,_s=size(s),_v=fix(false) +} +proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) +proc varray(a:any,s:mshape or dshape)=rec array_template { + _a=a,_d=s,_s=size(s),_v=fix(true) +} +proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) +proc _zero(x)=0 +proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) +// Treat a template as if it were an array +proc _arb(a:array_template)=a._a +proc #(a:array_template(,mshape,))=a._d +proc dims(a:array_template(,mshape,))=dims(a._d) +proc size(a:array_template)=a._s +proc redim(a:array_template,d:mshape)= rec array_template { +_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s +proc element(a:array_template,...:subs)=a._a +// Array creation from template + +proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) +proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) +proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) + // *************************************************** // LOOPS AND PARALLEL STATEMENTS @@ -1529,11 +1648,10 @@ PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) <> { PM__for shape { here_in_tile=PM__generate(shape,shape) - old_dump(here_in_tile) PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { var inouts=PM__import(PM__inouts) var inout_a=PM__get_elem(PM__inout_a,here_in_tile) - PM__block_proc.'(&inouts, + PM__block_proc.'(&inouts, PM__import(PM__ins), &inout_a, PM__get_elem(PM__in_a,here_in_tile), diff --git a/src/codegen.f90 b/src/codegen.f90 index 2f0c04a..7607ae4 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -3866,7 +3866,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) logical:: is_present,also_present,type_present logical:: dotdotdot_present,multiple_modules,twice,has_constraints integer:: name,nargs,sym,i,base,parbase,ibase,npars,idepth - integer:: new_type + integer:: new_type,gatebase ! Type name and arguments nargs=node_numargs(node)-1 @@ -4068,9 +4068,10 @@ recursive subroutine trav_type_decl(coder,pnode,node) also_present=.true. also_dec=dec pargs=node_get(dec,type_params) + gatebase=-1 call make_type_vars(coder,name,& pnode,node,pargs,base-nargs,nargs,& - parbase,npars) + parbase,npars,gatebase=gatebase) inc=node_get(dec,type_includes) if(.not.pm_fast_isnull(inc)) then do i=1,node_numargs(inc) @@ -4080,6 +4081,9 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif enddo endif + if(gatebase>=0) then + call make_type(coder,coder%wtop-gatebase) + endif call pop_type_vars(coder) else ! sym_dotdotdot, sym_includes @@ -4282,15 +4286,16 @@ end function trav_rec_decl ! If parbase is not present, leave parameters on wstack !=========================================================== subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& - parbase,nbasepars) + parbase,nbasepars,gatebase) type(code_state),intent(inout):: coder integer,intent(in):: parent type(pm_ptr),intent(in):: pnode,callnode,pnames integer,intent(in):: argbase,nargs integer,intent(in),optional:: parbase integer,intent(in),optional:: nbasepars + integer,intent(out),optional:: gatebase integer:: k,base,wbase,npars - integer:: vtyp,partyp,name,pname + integer:: vtyp,partyp,vvtyp,name,pname logical:: check_against_base check_against_base=.false. name=node_num_arg(callnode,node_numargs(callnode)) @@ -4322,7 +4327,7 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& coder%top=coder%top+1 coder%stack(coder%top)=typevar_start coder%var(coder%top)=pm_null_obj - + base=coder%top wbase=coder%wtop if(.not.present(parbase)) then @@ -4359,7 +4364,19 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& call push_word(coder,min(vtyp,partyp)) call push_word(coder,max(vtyp,partyp)) call make_type(coder,4) + vvtyp=vtyp vtyp=pop_word(coder) + + ! Push information on vstack to make gated type + ! which checks for null intersections between + ! arguments and parameters + if(gatebase<0) then + gatebase=coder%wtop + call push_word(coder,pm_type_new_gated) + call push_word(coder,0) + endif + call push_word(coder,vvtyp) + call push_word(coder,partyp) endif else diff --git a/src/infer.f90 b/src/infer.f90 index 199253e..8ab7ec8 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -3817,7 +3817,7 @@ subroutine print_proc_details(coder,node) type(pm_ptr),intent(in):: node integer:: name integer:: istart,n,tno,nret,i - character(len=512):: str,str2,buf1,buf2 + character(len=1024):: str,str2,buf1,buf2 if(.not.pm_main_process) return if(coder%supress_errors) return name=cnode_get_num(node,pr_name) diff --git a/src/main.f90 b/src/main.f90 index cb82002..bf2557a 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -137,6 +137,12 @@ subroutine run_parser(mname,root,dict,visibility) !write(*,*) 'Parsing',trim(str) call parse_file_on_unit(parser,pm_comp_file_unit,.false.) close(pm_comp_file_unit) + if(parser%error_count>0) then + if(pm_main_process) then + write(*,*) 'Cannot parse system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif !!$ !!$ call sysdefs(parser) diff --git a/src/opts.f90 b/src/opts.f90 index cc86b49..afd4924 100755 --- a/src/opts.f90 +++ b/src/opts.f90 @@ -41,6 +41,7 @@ module pm_options logical:: old_files integer:: proc_list logical:: show_variants + logical:: show_details logical:: check_alias logical:: show_all_ref logical:: print_immediate @@ -86,6 +87,7 @@ subroutine init_opts(context) pm_opts%see_all_procs=.false. pm_opts%proc_list=11 pm_opts%show_variants=.false. + pm_opts%show_details=.false. pm_opts%check_alias=.not.pm_is_compiling pm_opts%show_all_ref=.false. pm_opts%print_immediate=.false. @@ -166,6 +168,7 @@ subroutine help write(*,*) ' -fshow-elems Show structure/record elements in error messages.' write(*,*) ' -fshow-members Show members of user defined types in error messages' write(*,*) ' -fshow-variants Show all variants for proc types' + write(*,*) ' -fshow-details Show extra details of types' write(*,*) ' -fshow-hidden Show hidden procedure parameters' write(*,*) ' -fsee-all-procs List all alternative procedures in error messages' write(*,*) ' -fproc-list=n Maximum number of procs to list if see-all-procs not invoked' @@ -291,6 +294,8 @@ subroutine pm_get_command_line(context,mname) pm_opts%show_members=.true. elseif(arg=='-fshow-variants') then pm_opts%show_variants=.true. + elseif(arg=='-fshow-details') then + pm_opts%show_details=.true. elseif(arg=='-fsee-all-procs') then pm_opts%see_all_procs=.true. elseif(arg=='-falias-check') then diff --git a/src/parser.f90 b/src/parser.f90 index 9e9cc0c..2b8d1ea 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -2256,7 +2256,9 @@ recursive function subscript(parser) result(iserr) integer:: n,sym iserr=.true. call scan(parser) - n=0 + n=1 + call push_sym_val(parser,sym_topology) + call make_node(parser,sym_name,1) sym=sym_list do if(parser%sym==sym_dotdotdot) then @@ -2272,7 +2274,7 @@ recursive function subscript(parser) result(iserr) if(parser%sym/=sym_comma) exit call scan(parser) enddo - if(n>7) then + if(n>8) then call parse_error(parser,'Cannot have more than seven dimensions in tuple or subscript') endif call make_node(parser,sym,n) @@ -4018,6 +4020,11 @@ recursive function typval(parser) result(iserr) case(sym_any) call scan(parser) call make_node(parser,sym_any,0) + case(sym_number) + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call scan(parser) + call make_node(parser,sym_literal,1) case(sym_fix,sym_literal) call scan(parser) if(sym==sym_literal.and.parser%sym/=sym_open) then @@ -4664,7 +4671,7 @@ function proc_decl(parser) result(iserr) thispar=-1 open=sym_open close=sym_close - + ! Line and position of procedure start call get_sym_pos(parser,line,pos) call scan(parser) @@ -4713,7 +4720,7 @@ function proc_decl(parser) result(iserr) dot_type=pm_null_obj endif - + ! Communicating proc flags if(.not.isref) then if(parser%sym==sym_pct) then @@ -4756,11 +4763,11 @@ function proc_decl(parser) result(iserr) ! Return types ->(typelist) if(parser%sym==sym_arrow) then call scan(parser) - if(expect(parser,sym_open)) return + if(expect(parser,sym_open)) goto 999 if(parser%sym==sym_close) then nret=0 else - if(moded_typ_list(parser,iscomm,nret)) return + if(moded_typ_list(parser,iscomm,nret)) goto 999 if(expect(parser,sym_close)) return endif call make_node(parser,sym_list,nret) @@ -4773,7 +4780,7 @@ function proc_decl(parser) result(iserr) endif if(parser%sym==sym_yield) then - if(yield_clause()) return + if(yield_clause()) goto 999 endif if(iscomm) then @@ -4816,6 +4823,7 @@ function proc_decl(parser) result(iserr) flags=ior(flags,proc_is_open) endif + ! = expr or [ check expr ] block if(parser%sym==sym_assign.and.nret==-1) then @@ -4898,14 +4906,13 @@ function proc_decl(parser) result(iserr) endif endif call push_null_val(parser) ! Code tree - - - if(parser%error_count>scount) then + + if(parser%error_count>0) then parser%vtop=sbase + if(parser%error_count==scount) iserr=.false. goto 999 endif - if(parser%error_count>0) goto 999 ! Assign flags to proc_flags slot parser%vstack(parser%vtop-& @@ -4951,6 +4958,14 @@ function yield_clause() result(iserr) integer:: m,n,i,k,base,first type(pm_ptr):: params,amps iserr=.true. + + if(parser%error_count>0) then + call scan(parser) + if(proctyp(parser,yield=.true.)) return + iserr=.false. + return + endif + if(iand(flags,proccall_is_ref)/=0) then call parse_error(parser,'Cannot have a "yield" clause in a method') elseif(iand(flags,proccall_is_comm)/=0) then diff --git a/src/types.f90 b/src/types.f90 index 17570a1..be26f2a 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -80,7 +80,7 @@ module pm_types integer,parameter:: pm_type_new_literal_value=19 integer,parameter:: pm_type_new_except=20 integer,parameter:: pm_type_new_param=21+pm_type_has_params - + integer,parameter:: pm_type_new_gated=22 integer,parameter:: pm_type_new_has=23 integer,parameter:: pm_type_new_vect=24+pm_type_has_vect integer,parameter:: pm_type_new_params=25 @@ -114,7 +114,7 @@ module pm_types integer,parameter:: pm_type_is_literal_value=19 integer,parameter:: pm_type_is_except=20 integer,parameter:: pm_type_is_param=21 - ! + integer,parameter:: pm_type_is_gated=22 integer,parameter:: pm_type_is_has=23 integer,parameter:: pm_type_is_vect=24 integer,parameter:: pm_type_is_params=25 @@ -143,7 +143,6 @@ module pm_types integer,parameter:: pm_elem_not_found=1 integer,parameter:: pm_elem_clash=2 - ! Error codes from type testing integer,parameter:: pm_type_err_none=0 integer,parameter:: pm_type_err_elem=1 @@ -186,7 +185,6 @@ module pm_types integer,public,parameter:: pm_string_literal_type = pm_last_category_type + 4 integer,public,parameter:: pm_last_literal_type = pm_string_literal_type - ! Kind of dref type (internal type describing references) integer,public,parameter:: pm_dref_is_dot=0 integer,public,parameter:: pm_dref_is_var=-1 @@ -1503,6 +1501,13 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& mode,params,base,user,ubase) return + case(pm_type_is_gated) + if(test_gated_type(context,q)) then + ok=pm_test_type_includes(context,p,pm_tv_arg(u,pm_tv_numargs(u)),& + mode,params,base,user,ubase) + else + ok=.true. + endif case(pm_type_is_bottom) ok=.true. return @@ -1803,6 +1808,13 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=tk==uk if(ok) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& mode,params,base,user,ubase) + case(pm_type_is_gated) + if(test_gated_type(context,p)) then + ok=pm_test_type_includes(context,pm_tv_arg(t,pm_tv_numargs(t)),q,& + mode,params,base,user,ubase) + else + ok=.false. + endif case(pm_type_is_bottom) ok=.false. case(pm_type_is_category) @@ -1969,13 +1981,270 @@ recursive function pm_type_contains_elem(context,p,q,& pm_type_is_contains,pm_type_is_has,& pm_type_is_params,pm_type_is_param) ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) + case(pm_type_is_gated) + if(test_gated_type(context,q)) then + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,pm_tv_numargs(u)),& mode,params,base,user,ubase) + else + ok=.true. + endif case default ok=.false. end select end function pm_type_contains_elem + recursive function pm_type_intersects(context,tno1,tno2,user,userbase) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno1,tno2,userbase + integer,intent(inout):: user(:) + logical:: ok + integer:: tk1,tk2 + type(pm_ptr):: tv1,tv2,r + integer:: n1,n2,i,j + + if(tno1==tno2) then + ok=.true. + return + endif + if(tno1==0.or.tno2==0) then + ok=.true. + return + endif + if(pm_type_includes(context,tno2,tno1,pm_type_incl_type)) then + ok=.true. + return + endif + if(pm_type_includes(context,tno1,tno2,pm_type_incl_type)) then + ok=.true. + return + endif + if(pm_type_is_concrete(context,tno1).or.pm_type_is_concrete(context,tno2)) then + ok=.false. + return + endif + tv1=pm_type_vect(context,tno1) + tv2=pm_type_vect(context,tno2) + tk1=pm_tv_kind(tv1) + tk2=pm_tv_kind(tv2) + n1=pm_tv_numargs(tv1) + n2=pm_tv_numargs(tv2) + + select case(tk2) + case(pm_type_is_user) + if(tk1/=pm_type_is_user) then + do i=2,userbase,2 + if(user(i)==tno1.and.user(i+1)==tno2) then + ok=.true. + return + endif + enddo + if(userbase+2>size(user)) then + call pm_panic('Program too complex - nested type defs') + endif + user(userbase+1)=tno1 + user(userbase+2)=tno2 + r=pm_dict_val(context,context%tcache,int(tno2,pm_ln)) + ok=pm_type_intersects(context,tno1,int(r%offset),user,userbase+2) + return + endif + return + case(pm_type_is_any) + if(tk1==pm_type_is_any) then + ok=.false. + do i=1,n1 + do j=1,n2 + if(i/=j) then + if(pm_type_intersects(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + user,userbase)) then + ok=.true. + return + endif + endif + enddo + enddo + else + ok=.false. + do j=1,n2 + if(pm_type_intersects(context,tno1,pm_tv_arg(tv2,j),& + user,userbase)) then + ok=.true. + return + endif + enddo + endif + return + case(pm_type_is_all) + if(tk1==pm_type_is_all) then + ok=.true. + do i=1,n1 + do j=1,n2 + if(i/=j) then + if(.not.pm_type_intersects(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + user,userbase)) then + ok=.false. + return + endif + endif + enddo + enddo + else + ok=.true. + do j=1,n2 + if(.not.pm_type_intersects(context,tno1,pm_tv_arg(tv2,j),& + user,userbase)) then + ok=.false. + return + endif + enddo + endif + return + case(pm_type_is_contains,pm_type_is_category,pm_type_is_bottom) + ok=.true. + return + case(pm_type_is_gated) + if(test_gated_type(context,tno2)) then + ok=pm_type_intersects(context,tno1,pm_tv_arg(tv2,pm_tv_numargs(tv2)),& + user,userbase) + else + ok=.true. + endif + return + case(pm_type_is_par_kind,pm_type_is_vect,pm_type_is_has,& + pm_type_is_params,pm_type_is_param) + ok=pm_type_intersects(context,pm_tv_arg(tv2,1),tno2,user,userbase) + return + case(pm_type_is_except) + if(tk1==pm_type_is_except) then + if(pm_type_intersects(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + user,userbase)) then + if(pm_type_includes(context,pm_tv_arg(tv2,2),pm_tv_arg(tv1,1),pm_type_incl_type)) then + ok=.false. + return + endif + if(pm_type_includes(context,pm_tv_arg(tv1,2),pm_tv_arg(tv2,1),pm_type_incl_type)) then + ok=.false. + return + endif + ok=.true. + return + else + ok=.false. + endif + else + if(pm_type_intersects(context,tno1,pm_tv_arg(tv2,1),& + user,userbase)) then + if(pm_type_includes(context,pm_tv_arg(tv2,2),tno1,pm_type_incl_type)) then + ok=.false. + return + endif + ok=.true. + else + ok=.false. + endif + endif + return + end select + + + select case(tk1) + case(pm_type_is_user) + do i=2,userbase,2 + if(user(i)==tno1.and.user(i+1)==tno2) then + ok=.true. + return + endif + enddo + if(userbase+2>size(user)) then + call pm_panic('Program too complex - nested type defs') + endif + user(userbase+1)=tno1 + user(userbase+2)=tno2 + r=pm_dict_val(context,context%tcache,int(tno1,pm_ln)) + ok=pm_type_intersects(context,int(r%offset),tno2,user,userbase+2) + case(pm_type_is_any) + ok=.false. + do i=1,n1 + if(pm_type_intersects(context,tno1,pm_tv_arg(tv1,i),& + user,userbase)) then + ok=.true. + return + endif + enddo + case(pm_type_is_all) + ok=.true. + do i=1,n1 + if(pm_type_intersects(context,tno1,pm_tv_arg(tv1,i),& + user,userbase)) then + ok=.true. + return + endif + enddo + case(pm_type_is_except) + if(pm_type_intersects(context,pm_tv_arg(tv1,1),tno2,& + user,userbase)) then + if(pm_type_includes(context,pm_tv_arg(tv2,2),tno1,pm_type_incl_type)) then + ok=.false. + return + endif + ok=.true. + else + ok=.false. + endif + case(pm_type_is_contains,pm_type_is_category,pm_type_is_bottom) + ok=.true. + case(pm_type_is_par_kind,pm_type_is_vect,pm_type_is_has,& + pm_type_is_params,pm_type_is_param) + ok=pm_type_intersects(context,pm_tv_arg(tv1,1),tno2,user,userbase) + case(pm_type_is_gated) + if(test_gated_type(context,tno1)) then + ok=pm_type_intersects(context,pm_tv_arg(tv1,pm_tv_numargs(tv1)),tno2,& + user,userbase) + else + ok=.true. + endif + case default + if(tk1/=tk2) then + ok=.false. + return + endif + if(pm_tv_name(tv1)/=pm_tv_name(tv2)) then + ok=.false. + return + endif + if(n1/=n2) then + ok=.false. + return + endif + do i=1,n1 + if(.not.pm_type_intersects(context,pm_tv_arg(tv1,i),pm_tv_arg(tv2,i),& + user,userbase)) then + ok=.false. + return + endif + enddo + ok=.true. + end select + end function pm_type_intersects + + function test_gated_type(context,tno) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno + logical:: ok + integer:: i + type(pm_ptr):: tv + integer::stack(max_user_nesting) + tv=pm_type_vect(context,tno) + do i=1,pm_tv_numargs(tv)-1,2 + if(.not.pm_type_intersects(context,pm_tv_arg(tv,i),pm_tv_arg(tv,i+1),stack,1)) then + ok=.false. + return + endif + enddo + ok=.true. + end function test_gated_type + !=============================================== ! Perform enveloping conversions if possible ! Returns -1 if not possible @@ -2404,7 +2673,7 @@ function pm_type_as_string(context,tno,distr) result(str) type(pm_context),pointer:: context integer,intent(in):: tno logical,intent(in),optional:: distr - character(len=256):: str + character(len=1024):: str integer:: n str='' if(tno==0) then @@ -2418,7 +2687,7 @@ end function pm_type_as_string recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,tuple_start) type(pm_context),pointer:: context integer,intent(in):: typno - character(len=256),intent(inout):: str + character(len=1024),intent(inout):: str integer,intent(inout):: n logical,intent(in),optional:: distr,tuple,noequiv integer,intent(in),optional:: tuple_start @@ -2439,11 +2708,11 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t return endif if(tno<0) then - if(add_char('*Internal error(<0)*')) return + if(add_char('*Internal-error(<0)*')) return return endif if(tno>pm_dict_size(context,context%heap%tcache)) then - if(add_char('*Internal error(>size)*')) return + if(add_char('*Internal-error(>size)*')) return return endif tv=pm_type_vect(context,tno) @@ -2524,7 +2793,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t case(pm_type_is_tuple,pm_type_is_vtuple) istart=1 if(present(tuple_start)) istart=tuple_start - if(iand(pm_tv_flags(tv),pm_type_is_list)/=0) then + if(iand(pm_tv_flags(tv),pm_type_is_list)/=0.and.pm_opts%show_details) then if(add_char('PM__list(')) return else if(add_char('(')) return @@ -2614,8 +2883,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t endif n=len_trim(str)+1 if(n>len(str)-10) return - if(iand(pm_tv_flags(tv),pm_type_has_distributed)/=0) then - if(add_char('*distr*')) return + if(pm_opts%show_details) then + if(iand(pm_tv_flags(tv),pm_type_has_distributed)/=0) then + if(add_char('*distr*')) return + endif endif case(pm_type_is_dref) if(pm_opts%show_all_ref) then @@ -2777,13 +3048,17 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t else istart=2 endif - do i=1,istart - if(pm_type_arg(context,pm_tv_arg(tv,1),i)/=0) then - if(add_char('^')) return - istart=1 - exit - endif - enddo + if(pm_opts%show_hidden) then + istart=1 + elseif(pm_opts%show_details) then + do i=1,istart + if(pm_type_arg(context,pm_tv_arg(tv,1),i)/=0) then + if(add_char('^')) return + istart=1 + exit + endif + enddo + endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,tuple_start=istart) if(add_char('->')) return call pm_type_to_string(context,pm_tv_arg(tv,2),str,n) @@ -2803,30 +3078,67 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t endif if(add_char(')')) return case(pm_type_is_vect) - if(add_char('^^(')) return + if(pm_opts%show_details) then + if(add_char('^^(')) return + endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) - if(add_char(')')) return + if(pm_opts%show_details) then + if(add_char(')')) return + endif case(pm_type_is_par_kind) name=pm_tv_name(tv) if(add_char(trim(sym_names(name)))) return if(add_char(' ')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) case(pm_type_is_param,pm_type_is_params) - if(add_char('$')) return + if(pm_opts%show_details) then + if(add_char('{')) return + endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) + if(pm_opts%show_details) then + if(add_char('}')) return + endif + case(pm_type_is_gated) + if(pm_opts%show_details) then + if(add_char('{')) return + if(.not.test_gated_type(context,tno)) then + if(add_char('~')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n,noequiv=.true.) + if(add_char(':')) return + do i=1,pm_tv_numargs(tv)-2,2 + if(no_intersect(pm_tv_arg(tv,i),pm_tv_arg(tv,i+1))) then + if(add_char('~')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,noequiv=.true.) + if(add_char('^')) return + call pm_type_to_string(context,pm_tv_arg(tv,i+1),str,n,noequiv=.true.) + if(i')) return case(pm_type_is_uninitialised) - if(add_char('UNINIT:')) return + if(pm_opts%show_details) then + if(add_char('UNINIT:')) return + endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) case(pm_type_is_bottom) if(add_char(' _ ')) return case default - if(add_char('?')) return - write(str(n:n+3),'(i4)') tk - n=len_trim(str)+1 + if(add_char('*Internal-error(kind='//& + trim(pm_int_as_string(tk))//')*')) return end select contains include 'fvkind.inc' @@ -2906,6 +3218,13 @@ function show_equiv(name,templ,typ) result(ok) endif end function show_equiv + function no_intersect(tno1,tno2) result(ok) + integer,intent(in):: tno1,tno2 + logical:: ok + integer:: stack(max_user_nesting) + ok=.not.pm_type_intersects(context,tno1,tno2,stack,1) + end function no_intersect + end subroutine pm_type_to_string subroutine dump_type(context,iunit,tno) From 130b691a03433a94849bd5243147a9f7a2fd5760 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 29 May 2025 16:07:59 +0100 Subject: [PATCH 22/36] Test/check --- pm/lib/sys/pm.pmm | 594 +++++++++++++++++++++------------------------- src/codegen.f90 | 20 +- src/infer.f90 | 39 ++- src/parser.f90 | 25 +- src/symbol.f90 | 2 +- src/vmdefs.f90 | 4 +- 6 files changed, 329 insertions(+), 355 deletions(-) diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm index d92bff8..8ab1921 100644 --- a/pm/lib/sys/pm.pmm +++ b/pm/lib/sys/pm.pmm @@ -713,7 +713,8 @@ type tuple5d(t1,t2,t3,t4,t5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM_ type tuple6d(t1,t2,t3,t4,t5,t6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6} type tuple7d(t1,t2,t3,t4,t5,t6,t7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7} -type tuple(t,r:literal(int)) +type dimension_number is 1,2,3,4,5,6,7 +type tuple(t,r:dimension_number) type tuple(t,r:1) is ...,tuple1d(t) type tuple(t,r:2) is ...,tuple2d(t,t) type tuple(t,r:3) is ...,tuple3d(t,t,t) @@ -744,42 +745,42 @@ proc tuple(x,y,z,t,u,v,w)=rec tuple7d { PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w } -proc dim(t:tuple1d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple2d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple3d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple4d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple5d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple6d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple7d,n:fix(1) or [fix(1)])=t.1 -proc dim(t:tuple2d,n:fix(2) or [fix(2)])=t.2 -proc dim(t:tuple3d,n:fix(2) or [fix(2)])=t.2 -proc dim(t:tuple4d,n:fix(2) or [fix(2)])=t.2 -proc dim(t:tuple5d,n:fix(2) or [fix(2)])=t.2 -proc dim(t:tuple6d,n:fix(2) or [fix(2)])=t.2 -proc dim(t:tuple7d,n:fix(2) or [fix(2)])=t.2 -proc dim(t:tuple3d,n:fix(3) or [fix(3)])=t.3 -proc dim(t:tuple4d,n:fix(3) or [fix(3)])=t.3 -proc dim(t:tuple5d,n:fix(3) or [fix(3)])=t.3 -proc dim(t:tuple6d,n:fix(3) or [fix(3)])=t.3 -proc dim(t:tuple7d,n:fix(3) or [fix(3)])=t.3 -proc dim(t:tuple4d,n:fix(4) or [fix(4)])=t.4 -proc dim(t:tuple5d,n:fix(4) or [fix(4)])=t.4 -proc dim(t:tuple6d,n:fix(4) or [fix(4)])=t.4 -proc dim(t:tuple7d,n:fix(4) or [fix(4)])=t.4 -proc dim(t:tuple5d,n:fix(5) or [fix(5)])=t.5 -proc dim(t:tuple6d,n:fix(5) or [fix(5)])=t.5 -proc dim(t:tuple7d,n:fix(5) or [fix(5)])=t.5 -proc dim(t:tuple6d,n:fix(6) or [fix(6)])=t.6 -proc dim(t:tuple7d,n:fix(6) or [fix(6)])=t.6 -proc dim(t:tuple7d,n:fix(7) or [fix(7)])=t.7 - -proc indices(x:tuple1d)=[fix(1)] -proc indices(x:tuple2d)=[fix(1),fix(2)] -proc indices(x:tuple3d)=[fix(1),fix(2),fix(3)] -proc indices(x:tuple4d)=[fix(1),fix(2),fix(3),fix(4)] -proc indices(x:tuple5d)=[fix(1),fix(2),fix(3),fix(4),fix(5)] -proc indices(x:tuple6d)=[fix(1),fix(2),fix(3),fix(4),fix(5),fix(6)] -proc indices(x:tuple7d)=[fix(1),fix(2),fix(3),fix(4),fix(5),fix(6),fix(7)] +proc dim(t:tuple1d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple3d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple4d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple5d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple6d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple7d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple4d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple5d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple6d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple7d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple5d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple6d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple7d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple6d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple7d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple7d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(7) or [literal(7)])=t.7 + +proc indices(x:tuple1d)=[literal(1)] +proc indices(x:tuple2d)=[literal(1),literal(2)] +proc indices(x:tuple3d)=[literal(1),literal(2),literal(3)] +proc indices(x:tuple4d)=[literal(1),literal(2),literal(3),literal(4)] +proc indices(x:tuple5d)=[literal(1),literal(2),literal(3),literal(4),literal(5)] +proc indices(x:tuple6d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6)] +proc indices(x:tuple7d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6),literal(7)] proc full_rank(x:tuple1d)=1 proc full_rank(x:tuple2d)=2 @@ -922,7 +923,8 @@ proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) -type empty_head is unique + +type empty_head is unique{empty_head} proc head(x:null)=empty_head proc head(x:tuple)=x.1 @@ -962,42 +964,42 @@ proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 -proc replace(x:tuple1d,y:fix(1),z)=[z] -proc replace(x:tuple2d,y:fix(1),z)=[z,x.2] -proc replace(x:tuple3d,y:fix(1),z)=[z,x.2,x.3] -proc replace(x:tuple4d,y:fix(1),z)=[z,x.2,x.3,x.4] -proc replace(x:tuple5d,y:fix(1),z)=[z,x.2,x.3,x.4,x.5] -proc replace(x:tuple6d,y:fix(1),z)=[z,x.2,x.3,x.4,x.5,x.6] -proc replace(x:tuple7d,y:fix(1),z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] -proc replace(x:tuple2d,y:fix(2),z)=[x.1,z] -proc replace(x:tuple3d,y:fix(2),z)=[x.1,z,x.3] -proc replace(x:tuple4d,y:fix(2),z)=[x.1,z,x.3,x.4] -proc replace(x:tuple5d,y:fix(2),z)=[x.1,z,x.3,x.4,x.5] -proc replace(x:tuple6d,y:fix(2),z)=[x.1,z,x.3,x.4,x.5,x.6] -proc replace(x:tuple7d,y:fix(2),z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] -proc replace(x:tuple3d,y:fix(3),z)=[x.1,x.2,z] -proc replace(x:tuple4d,y:fix(3),z)=[x.1,x.2,z,x.4] -proc replace(x:tuple5d,y:fix(3),z)=[x.1,x.2,z,x.4,x.5] -proc replace(x:tuple6d,y:fix(3),z)=[x.1,x.2,z,x.4,x.5,x.6] -proc replace(x:tuple7d,y:fix(3),z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] -proc replace(x:tuple4d,y:fix(4),z)=[x.1,x.2,x.3,z] -proc replace(x:tuple5d,y:fix(4),z)=[x.1,x.2,x.3,z,x.5] -proc replace(x:tuple6d,y:fix(4),z)=[x.1,x.2,x.3,z,x.5,x.6] -proc replace(x:tuple7d,y:fix(4),z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] -proc replace(x:tuple5d,y:fix(5),z)=[x.1,x.2,x.3,x.4,z] -proc replace(x:tuple6d,y:fix(5),z)=[x.1,x.2,x.3,x.4,z,x.6] -proc replace(x:tuple7d,y:fix(5),z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] -proc replace(x:tuple6d,y:fix(6),z)=[x.1,x.2,x.3,x.4,x.5,z] -proc replace(x:tuple7d,y:fix(6),z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] -proc replace(x:tuple7d,y:fix(7),z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] - -proc spread(x,y:tuple1d or fix(1))=[x] -proc spread(x,y:tuple2d or fix(2))=[x,x] -proc spread(x,y:tuple3d or fix(3))=[x,x,x] -proc spread(x,y:tuple4d or fix(4))=[x,x,x,x] -proc spread(x,y:tuple5d or fix(5))=[x,x,x,x,x] -proc spread(x,y:tuple6d or fix(6))=[x,x,x,x,x,x] -proc spread(x,y:tuple7d or fix(7))=[x,x,x,x,x,x,x] +proc replace(x:tuple1d,y:literal(1),z)=[z] +proc replace(x:tuple2d,y:literal(1),z)=[z,x.2] +proc replace(x:tuple3d,y:literal(1),z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:literal(1),z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:literal(2),z)=[x.1,z] +proc replace(x:tuple3d,y:literal(2),z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:literal(2),z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:literal(3),z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:literal(3),z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:literal(4),z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:literal(7),z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or literal(1))=[x] +proc spread(x,y:tuple2d or literal(2))=[x,x] +proc spread(x,y:tuple3d or literal(3))=[x,x,x] +proc spread(x,y:tuple4d or literal(4))=[x,x,x,x] +proc spread(x,y:tuple5d or literal(5))=[x,x,x,x,x] +proc spread(x,y:tuple6d or literal(6))=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or literal(7))=[x,x,x,x,x,x,x] proc +(x:tuple(num),y:tuple(num))=map($+,x,y) @@ -1035,6 +1037,47 @@ proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", // RANGES AND SEQUENCES // ***************************************************** +// Partial ranges and sequences for slicing +type underscore is unique{PM__underscore} +type _subscript is any_int,range(any_int),seq(any_int,any_int),underscore,range_below(any_int),range_above(any_int),seq_above(any_int,any_int), seq_below(any_int,any_int), seq_stride(any_int) +type subscript is _subscript or tuple(subscript) +type extent(ndim:dimension_number) is tuple(range(int),dimension_number) + +proc complete(x:extent,y:subscript)=_complete(x,y) check "Subscript "++y++" is out of bounds "++x=>y in x +proc _complete(x:tuple1d,y:_subscript)=_complete(x.1,y) +proc _complete(x:range(int),y:any_int)=int(y) +proc _complete(x:range(int),y:range(any_int))=int(y) +proc _complete(x:range(int),y:seq(any_int,any_int))=int(y) +proc _complete(x:range(int),y:underscore)=x +proc _complete(x:range(int),y:range_below(any_int))=low(x)..int(y._t) +proc _complete(x:range(int),y:range_above(any_int))=int(y._t)..high(x) +proc _complete(x:range(int),y:seq_below(any_int))=low(x)..int(y._t) by int(y._st) +proc _complete(x:range(int),y:seq_above(any_int))=int(y._t)..high(x) by int(y._st) +proc _complete(x:range(int),y:seq_step(any_int))=x by int(y._st) +proc _complete(x,y)=map($_complete,x,y) check "Subscript has incorrect rank"=>rank(x)==rank(y) + +type range_below(x:range_base) is rec {_t:x} +type range_above(x:range_base) is rec {_t:x} +type seq_below(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_above(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_step(x:step_base) is rec {_st:step_base} +proc ..(x:underscore,y:range_base)=rec range_below{_t=x} +proc ..(x:range_base,y:underscore)=rec range_above{_t=x} +proc by(x:range_below,y:step_base)=rec seq_below{_t=x,_st=y} +proc by(x:range_above,y:step_base)=rec seq_above{_t=x,_st=y} +proc by(x:underscore,y:step_base)=rec seq_step{_st=y} +proc string(x:range_below)="_.."++x._t +proc string(x:range_above)=x._t++".._" +proc string(x:seq_below)="_.."++x._t++" by "++x._st +proc string(x:seq_above)=x._t++".._ by "++x._st +proc string(x:seq_step)="_ by "++x._st +proc low(x:range_below or seq_below or seq_step)=_ +proc high(x:range_above or seq_above or seq_step)=_ +proc step(x:range_above or range_below)=literal(1) +proc low(x:range_above or seq_above)=x._t +proc high(x:range_below or seq_below)=x._t +proc step(x:seq_above or seq_below or seq_step)=x._st + // Not in operator proc notin(x,y)=not(x in y) @@ -1042,57 +1085,12 @@ proc notin(x,y)=not(x in y) proc notinc(x,y)=not(x inc y) // Treat null as empty sequence in some cases -proc in(x,y:null)=fix(false) -proc in(x:null,y:null)=fix(true) +proc in(x,y:null)=literal(false) +proc in(x:null,y:null)=literal(true) // Range base type (might later expand to interface) type range_base is real_num - -// Single point sequence -type single_point(t:range_base) is rec {_t:t} -proc single_point(x)=rec single_point { - _t=x -} -proc low(x:single_point)=x._t -proc high(x:single_point)=x._t -proc step(x:single_point)=x._t -proc width(x:single_point)=fix(1) -proc norm(x:single_point)=x -proc #(x:single_point)=shape([fix(0)..fix(0)]) -proc _shp(x:single_point)=fix(0)..fix(0) -proc dims(x:single_point)=[fix(1)] -proc size(x:single_point)=fix(1) -proc +(x:single_point,y:range_base)=rec single_point { - _t=x._t+y -} -proc -(x:single_point,y:range_base)=rec single_point { - _t=x._t-y -} -proc _arb(x:single_point)=x._t -proc in(x:range_base,y:single_point)=x==y._t -proc inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t -proc convert(x:single_point,y:range_base)=single_point(convert(x._t,y)) -proc sint(x:single_point)=single_point(sint(x._t)) -proc int(x:single_point)=single_point(int(x._t)) -proc sreal(x:single_point)=single_point(sreal(x._t)) -proc real(x:single_point)=single_point(real(x._t)) -proc #(x:single_point,y:index)=fix(0) -proc #(x:single_point,y:grid_slice_dim)=fix(0)..fix(0) -proc #(x:single_point,y:single_point)=fix(0)..fix(0) -proc #(x:grid_slice_dim,y:single_point)=single_point(xx) where xx=x#y._t -proc overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1) -proc overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1) -proc overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1) -proc overlap(x:single_point(any_int),y:single_point(any_int))=overlap(x,y),overlap(y,x) -proc overlap(x:grid_slice_dim,y:single_point(any_int))=overlap(x,y),overlap(y,x) -proc overlap(x:single_point(any_int),y:grid_slice_dim)=overlap(x,y),overlap(y,x) -proc intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1) -proc intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1) -proc intersect(x:single_point(any_int),y:single_point(any_int))=x._t..if(x._t==y._t=>x._t,x._t-1) -proc element(x:single_point,y:index)=x._t -proc element(x:single_point,y:subs)=x._t..x._t -proc element(x,y:single_point)=element(x,y._t) -proc string(x:single_point)=string("single "++x._t) +type step_base is real_num // Range types type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} @@ -1101,9 +1099,9 @@ _lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) proc low(x:range)=x._lo proc high(x:range)=x._hi proc step(x:range)=convert(1,x._lo) -proc width(x:range)=fix(1) +proc width(x:range)=literal(1) proc norm(x:range)=x -proc #(x:range(int))=shape([0..x._n-1]) +proc #'(x:range(int))=[0..x._n-1] proc dims(x:range(int))=[x._n] proc size(x:range(int))=x._n proc +(x:range,y:range_base)=rec range { @@ -1134,16 +1132,16 @@ proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st proc element(x:range(any_int),y:null)=x -proc element(x:range(any_int),y:grid_dim)=y+x._lo -proc #(y:range(any_int),x:int)=int(x-y._lo) -proc #(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) -proc #(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) -proc #(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) -proc #(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 -proc #(y:range(any_int),x:strided_range_below(int))=_intseq(0,int(x._t-y._lo),x._st) -proc #(y:range(any_int),x:strided_range_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) -proc #(y:range(any_int),x:stride(int))=_intseq(0,size(y),int(x._st)) -proc #(y:range(any_int),x:null)=0..size(y) +proc element(x:range(any_int),y:any_seq)=y+x._lo +proc #'(y:range(any_int),x:int)=int(x-y._lo) +proc #'(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #'(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #'(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #'(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #'(y:range(any_int),x:seq_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #'(y:range(any_int),x:seq_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #'(y:range(any_int),x:seq_step(int))=_intseq(0,size(y),int(x._st)) +proc #'(y:range(any_int),x:null)=0..size(y) proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi @@ -1153,85 +1151,72 @@ proc empty(x:range)=rec range { } proc string(x:range)=string(x._lo)++".."++(x._hi) -// Cyclic range types (limited functionality and not part of grid) -type cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int} -proc cyclic_range(x:int,y:int,w:int)=rec cyclic_range { -_lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) -proc low(x:cyclic_range)=x._lo -proc high(x:cyclic_range)=x._hi -proc size(x:cyclic_range)=x._n -proc element(x:cyclic_range,y:int)=(x._lo + y) mod x._w -proc string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")" - -// Strided range types -type strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int} -type _any_seq(t:range_base) is strided_range(t), ... -type _any_seq(t:any_int) is ..., range(t) -type seq(t:range_base) is _any_seq(t) -proc _seq(lo,hi,st)=rec strided_range { +// Sequence (strided range) types +type seq(t:range_base,s:step_base) is rec {_lo:t,_hi:t,_st:s,_n:int} +proc _seq(lo,hi,st)=rec seq { _lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y -proc _intseq(x:int,y:int,st:int)= rec strided_range { +proc _intseq(x:int,y:int,st:int)= rec seq { _lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) -proc low(x:strided_range)=x._lo -proc high(x:strided_range)=x._hi -proc step(x:strided_range)=x._st -proc size(x:strided_range)=x._n -proc width(x:strided_range)=fix(1) -proc norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo -proc align(x:seq)=fix(0) -proc #(x:strided_range)=shape([0..x._n-1]) -proc dims(x:strided_range)=[x._n] -proc +(x:strided_range,y:range_base)=rec strided_range { +proc low(x:seq)=x._lo +proc high(x:seq)=x._hi +proc step(x:seq)=x._st +proc size(x:seq)=x._n +proc width(x:seq)=literal(1) +proc norm(x:seq)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)=literal(0) +proc #'(x:seq)=[0..x._n-1] +proc dims(x:seq)=[x._n] +proc +(x:seq,y:range_base)=rec seq { _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n } -proc -(x:strided_range,y:range_base)=rec strided_range { +proc -(x:seq,y:range_base)=rec seq { _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n } proc _arb(x:seq)=x._lo -proc convert(x:strided_range,y:range_base)=rec strided_range { +proc convert(x:seq,y:range_base)=rec seq { _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n } -proc sint(x:strided_range)=rec strided_range { +proc sint(x:seq)=rec seq { _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n } -proc int(x:strided_range)=rec strided_range { +proc int(x:seq)=rec seq { _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n } -proc sreal(x:strided_range)=rec strided_range { +proc sreal(x:seq)=rec seq { _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n } -proc real(x:strided_range)=rec strided_range { +proc real(x:seq)=rec seq { _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n } -proc in(x:int,y:strided_range(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 -proc inc(x:strided_range(int),y:strided_range(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) -proc inc(x:strided_range(int),y:range(int) or single_point(int))=x inc low(y)..high(y) by 1 -proc #(y:seq,x:range_base)=int((x-y._lo)/y._st) -proc #(y:seq,x:range)=y#x._lo..y#x._hi -proc #(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi -proc #(y:seq,x:range_below)=0..y#x._t -proc #(y:seq,x:range_above)=y#x._t..size(y)-1 -proc #(y:seq,x:strided_range_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) -proc #(y:seq,x:strided_range_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) -proc #(y:seq,x:stride)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) -proc #(y:seq,x:null)=0..size(y)-1 -proc string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st -proc element(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st -proc element(x:strided_range,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) -proc element(x:strided_range,y:strided_range(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st -proc element(x:strided_range,y:null)=x -proc overlap(x:strided_range(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) -proc overlap(x:range(any_int),y:strided_range(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo -proc intersect(x:strided_range(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st -proc intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x) +proc in(x:int,y:seq(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:seq(int),y:seq(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:seq(int),y:range(int))=x inc low(y)..high(y) by 1 +proc #'(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #'(y:seq,x:range)=y#x._lo..y#x._hi +proc #'(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #'(y:seq,x:range_below)=0..y#x._t +proc #'(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #'(y:seq,x:seq_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_step)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:null)=0..size(y)-1 +proc string(x:seq)=x._lo++".."++x._hi++" by "++x._st +proc element(x:seq,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:seq,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:seq,y:seq(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:seq,y:null)=x +proc overlap(x:seq(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:seq(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:seq(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:seq(any_int))=intersect(y,x) PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" -proc intersect(x:strided_range(any_int),y:strided_range(any_int))=rec strided_range { +proc intersect(x:seq(any_int),y:seq(any_int))=rec seq { _lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) -proc overlap(x:strided_range(any_int),y:strided_range(any_int))=rec strided_range { +proc overlap(x:seq(any_int),y:seq(any_int))=rec seq { _lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) -proc empty(x:strided_range(any_int))=rec strided_range { +proc empty(x:seq(any_int))=rec seq { _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 } @@ -1255,7 +1240,7 @@ proc step(x:block_seq)=x._st proc width(x:block_seq)=x._b proc norm(x:block_seq)=x proc align(x:block_seq)=x._align -proc #(x:block_seq)=shape([0..x._n-1]) +proc #'(x:block_seq)=[0..x._n-1] proc dims(x:block_seq)=x._n proc size(x:block_seq)=x._n proc +(x:block_seq,y:int)=rec block_seq { @@ -1266,32 +1251,32 @@ proc -(x:block_seq,y:int)=rec block_seq { } proc _arb(x:block_seq)=x._lo proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st if hi-nbhi>=x._b:hi=nbhi+x._b-1 - align=base-(base/x._st)*x._st where base=lo-oldbase + let align=base-(base/x._st)*x._st where base=lo-oldbase return block_seq(lo,hi,x._st,x._b,align) } proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) proc overlap(x:range(any_int),y:block_seq) { - z=intersect(y,x) + let z=intersect(y,x) return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) } proc overlap(x:block_seq,y:range(any_int)) { - z=intersect(x,y) + let z=intersect(x,y) return start..start+size(z)-1 where start=z#z._lo } proc overlap(x:block_seq,y:range(any_int)) { - z=intersect(x,y) + let z=intersect(x,y) return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo } proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) @@ -1300,7 +1285,7 @@ proc empty(x:block_seq)=block_seq(1,0,1,1,0) /* // Mapped sequence type map_seq(t:array(int)) is rec {array:t} -proc map_seq(x:grid_dim){ +proc map_seq(x:any_seq){ var a=array(0,#x) forall i in a,j in x:i=j return rec map_seq{ @@ -1324,7 +1309,7 @@ proc _mono(x) { */ } proc map_seq(x:map_seq)=x -proc #(x:map_seq)=#(x.array) +proc #'(x:map_seq)=#'(x.array) proc dims(x:map_seq)=size(x.array) proc size(x:map_seq)=size(x.array) proc +(x:map_seq,y:range_base)=rec map_seq{ @@ -1395,7 +1380,7 @@ proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) -proc #(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc #'(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) proc empty(x:map_seq) { a=array(0,[1..0]) return rec map_seq { @@ -1406,121 +1391,44 @@ proc empty(x:map_seq) { proc map_seq(x)=x proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) + +type any_seq is range(int),seq(int,int),block_seq // , map_seq + // Grids (tuples of sequences) -type _grid_dim(t:range_base) is seq(t),... -type _grid_dim(t:int) is ...,block_seq //,map_seq -type grid_dim(t:range_base) is _grid_dim(t) -type grid1d(t1:grid_dim) is [t1] -type grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2] -type grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is [t1,t2,t3] -type grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is [t1,t2,t3,t4] -type grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim) is [t1,t2,t3,t4,t5] -type grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim) is [t1,t2,t3,t4,t5,t6] -type grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim,t7:grid_dim) is [t1,t2,t3,t4,t5,t6,t7] -type grid(t:range_base) is tuple(grid_dim(t)) -proc #(x:grid)=shape(map($_shp,x)) -proc dims(x:grid)=map($_size,x) +type _gdim is any_seq or int +type grid1d(t1:_gdim) is [t1] except [int] +type grid2d(t1:_gdim,t2:_gdim) is [t1,t2] except [int,int] +type grid3d(t1:_gdim,t2:_gdim,t3:_gdim) is [t1,t2,t3] except [int,int,int] +type grid4d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim) is [t1,t2,t3,t4] except [int,int,int,int] +type grid5d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim) is [t1,t2,t3,t4,t5] except [int,int,int,int,int] +type grid6d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim) is [t1,t2,t3,t4,t5,t6] except [int,int,int,int,int,int] +type grid7d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim,t7:_gdim) is [t1,t2,t3,t4,t5,t6,t7] except [int,int,int,int,int,int,int] +type grid(ndim:dimension_number) is tuple(_gdim,ndim) except tuple(int,ndim) + +PM__intrinsic _shp(x:int)->(PM__tinyint) : "miss_arg" +proc _shp(x)=0..size(x)-1 +proc _sliceit(...)=tuple(...) +proc #'(x:grid)=map_apply($_shp,$_sliceit,x) +PM__intrinsic _size(x:int)->(PM__tinyint) : "miss_arg" +proc _size(x)=x +proc dims(x:grid)=map_apply($_shp,$_sliceit,x) proc +(x:grid,y:tuple(range_base))=map($+,x,y) -proc -(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($-,x,y) proc empty(x:grid)=map($empty,x) -proc element(x:grid_dim,y:grid_dim){ - var a=array(0,#y) - forall i in a,j in y:i=x[j] - return rec map_seq{ - array=a - } -} -proc element(x:grid,y:grid)=map($element,x,y) - -// Slices of grids (may have dims that are just an integer and also _ or _() or null) -type grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null -type grid_slice(t) is grid(t),tuple(grid_slice_dim(t)) - -// Some limited functionality for extended grids (which include cyclic ranges) -type iterable_dim is grid_slice_dim,cyclic_range,... -type iterable_grid is tuple(iterable_dim),grid_slice -proc _shp(x:iterable_dim)=0..size(x)-1 -proc size(x:iterable_dim)->(int)... -proc element(x:iterable_dim,y)=error_type() - check "Cannot index this type with a non-integer index"=>fix(false) -proc element(x:iterable_dim,y:int)->(any)... -proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) -proc _shp(x:stretch_dim)=null -proc _shp(x:null)=x -proc _size(x:stretch_dim or null)=fix(1) -proc _size(x)=size(x) -PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" -proc _act(x)=x -proc _sliceit(...)=tuple(...) -proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) -proc active_dims(x:single_point)=null -PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" -proc _act(x,y)=y -proc active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y) -proc active_dims(x:single_point,y)=null -proc _ar(x:single_point)=0 -proc _ar(x)=1 -proc rank(x:iterable_grid)=map_reduce($_ar,$+,x) -proc element(x:iterable_grid,y:index){ - t=_tup(y) - return _ges(head(x),tail(x),head(t),tail(t),fix(false)) -} -proc element(x:grid_slice,...:grid_slice){ - t=_tup(...) - return _ges(head(x),tail(x),head(t),tail(t),fix(true)) -} -proc element(x:null,y)=null -proc _spnt(i,y:fix(true))=i -proc _spnt(i,y:fix(false))=i._t -proc _spif(i:int,y:fix(true))=single_point(i) -proc _spif(i,y:fix(true))=i -proc _spif(i,y:fix(false))=i -proc _ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) -proc _ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => fix(false) -proc _ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),_ges(head(x),tail(x),head(y),tail(y),t)) -proc _ges_null(i,x,j,y,t:fix(true))=prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t)) -proc _ges_null(i,x,j,y,t:fix(false))=_ges(head(x),tail(x),head(y),tail(y),t) -proc _ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t) -proc _ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) -proc _ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) -proc _ges(i:empty_head,x,j:empty_head,y,t)=null -proc _ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => fix(false) -proc _ges(i:null,x,j:empty_head,y,t:fix(true))=error_type() :test "Rank mismatch" => fix(false) -proc _ges(i:null,x,j:empty_head,y,t:fix(false))=null -proc size(x:iterable_grid)=map_reduce($_size,$*,x) -proc #(x:grid_slice)=shape(map($_shp,active_dims(x))) -proc dims(x:iterable_grid)=map($_size,active_dims(x)) -proc _arb(x:grid_slice)=map($_arb,x) -proc in(x:tuple(range_base),y:grid_slice)=map_reduce($in,$and,x,y) -proc inc(x:grid_slice,y:grid_slice)=map_reduce($inc,$and,x,y) -proc #(x:grid,y:tuple(subs_dim))=map($#,x,y) -PM__intrinsic _acthash(x:single_point,y:any)->(PM__tinyint) : "miss_arg" -proc _acthash(x,y)=x#y -proc #(x:grid_slice,y:tuple(subs_dim) or grid_slice)=map_apply($_acthash,$_sliceit,x,y) -proc convert(x:grid_slice,y:real_num)=map_const($convert,x,y) -proc sint(x:grid_slice)=map($sint,x) -proc int(x:grid_slice)=map($int,x) -proc sreal(x:grid_slice)=map($sreal,x) -proc real(x:grid_slice)=map($real,x) -proc low(x:grid_slice)=map($low,x) -proc high(x:grid_slice)=map($high,x) -proc overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y) -proc overlap(x:grid_slice,y:grid_slice)=u,v where u,v=map($overlap,x,y) -proc intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y) -proc intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y)) -proc overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y)) -proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y)) -proc expand(x:grid_slice,y:grid)=map($expand,x,y) -proc contact(x:grid_slice,y:grid)=map($contract,x,y) -PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" +proc element(x:tuple(any_seq),y)=map($element,x,y) +proc element(x:grid,y)=_gel(head(x),tail(x),head(y),tail(y)) +proc _gel(x:_gdim,xx,y,yy)=prepend(element(x,y),_gel(head(xx),tail(xx),head(yy),tail(yy))) +proc _gel(x:int,xx,y,yy)=prepend(x,_gel(head(xx),tail(xx),y,yy)) +proc _gel(x:empty_head,xx,y:empty_head,yy)=null +proc _gel(x:empty_head,xx,y,yy)=error_type():test "Rank mismatch"=>fix(false) + + // ************************************** // ARRAYS // ************************************** +/* // Array types type array(e,d:shape) is varray(e,d),farray(e,d) type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) @@ -1543,7 +1451,7 @@ PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(=x) : "array_noi proc #%(x:invar any^any)=_array_shape(x <>) proc #%(x)=_get_shape(x) proc _get_shape(x)=#x -proc #(x:any^any)=_array_shape(x) +proc #'(x:any^any)=_array_shape(x) PM__intrinsic _array_shape(x:any^any)->(=x) : "get_dom" proc dims(x:any^mshape)=dims(#x) PM__intrinsic PM__extractelm(x:any^any)->(=x) : "extractelm" @@ -1557,23 +1465,51 @@ PM__intrinsic _make_subref(a:any^mshape,i:int)->(=a) : "make_rf" PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +*/ + +type _mshape(ndim,contig:literal(bool)) is rec {_extent:extent(ndim),_m:tuple(int,ndim),_n:int,_o:int,_c:contig} + +proc _mshape(g:extent(1))=rec _mshape{_extent=g,_m=[1],_n=size(g.1),_o=0,_c=true} +proc _mshape(g:extent(2))=rec _mshape{_extent=g,_m=[1,s1],_n=s1*size(g.2),_o=0,_c=true} where s1=size(g.1) +proc _mshape(g:extent(3))=rec _mshape{_extent=g,_m=[1,s1,s2],_n=s2*size(g.3),_o=0,_c=true} where s2=s1*size(g.2) where s1=size(g.1) +proc _mshape(g:extent(4))=rec _mshape{_extent=g,_m=[1,s1,s3,s3],_n=s3*size(g.4),_o=0,_c=true} where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) +proc _mshape(g:extent(5))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4],_n=s4*size(g.5),_o=0,_c=true} where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) + +proc _mshape(g:extent(6))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5],_n=s5*size(g.6),_o=0,_c=true} where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) +proc _mshape(g:extent(7))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5,s6],_n=s6*size(g.7),_o=0,_c=true} where s6=s5*size(g.6) where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) + +/* +proc _point2index(g:_mshape,p:tuple(any_int))=_point2index(g,int(p)) +proc _point2index(g:_mshape(1,true),p:tuple(int,1))=g._o+g._m.1*p.1 +proc _point2index(g:_mshape(2,true),p:tuple(int,2))=g._o+g._m.1*p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,true),p:tuple(int,3))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,true),p:tuple(int,4))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,true),p:tuple(int,5))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,true),p:tuple(int,6))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,true),p:tuple(int,7))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape(1,false),p:tuple(int,1))=g._o+p.1 +proc _point2index(g:_mshape(2,false),p:tuple(int,2))=g._o+p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,false),p:tuple(int,3))=g._o+p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,false),p:tuple(int,4))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,false),p:tuple(int,5))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,false),p:tuple(int,6))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,false),p:tuple(int,7))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape,p:tuple(int))=0 check "Rank mismatch in array index"=>fix(false) +*/ + // Linear index of tuple mshape (zero base,unit stride) -proc _indx(g:null,s)=literal(0) proc _indx(g:range(int),s)=int(s) proc _indx(g:any_int,s)=int(s) -proc _sz(x:null)=literal(1) proc _sz(x:int)=x proc _sz(x:range(int))=x._n -proc _offset(x:mshape)=x._o -proc _offset(x)=literal(0) -proc _point2index(g:mshape1d or tuple(int,1),s:any_int)=int(_indx(g.1,s))+_offset(g) -proc _point2index(g:mshape1d or tuple(int,1),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g) -proc _point2index(g:mshape2d or tuple(int,2),s:tuple2d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2))+_offset(g) -proc _point2index(g:mshape3d or tuple(int,3),s:tuple3d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3)))+_offset(g) -proc _point2index(g:mshape4d or tuple(int,4),s:tuple4d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4))))+_offset(g) -proc _point2index(g:mshape5d or tuple(int,5),s:tuple5d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5)))))+_offset(g) -proc _point2index(g:mshape6d or tuple(int,6),s:tuple6d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6))))))+_offset(g) -proc _point2index(g:mshape7d or tuple(int,7),s:tuple7d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7))))))))+_offset(g) +proc _point2index(g:tuple(int,1) or extent(1),s:any_int)=int(_indx(g.1,s)) +proc _point2index(g:tuple(int,1) or extent(1),s:tuple(any_int,1))=int(_indx(g.1,s.1)) +proc _point2index(g:tuple(int,2) or extent(2),s:tuple(any_int,2))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2)) +proc _point2index(g:tuple(int,3) or extent(3),s:tuple(any_int,3))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3))) +proc _point2index(g:tuple(int,4) or extent(4),s:tuple(any_int,4))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4)))) +proc _point2index(g:tuple(int,5) or extent(5),s:tuple(any_int,5))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5))))) +proc _point2index(g:tuple(int,6) or extent(6),s:tuple(any_int,6))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6)))))) +proc _point2index(g:tuple(int,7) or extent(7),s:tuple(any_int,7))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7)))))))) proc _index2point(i:int,s:range(int))=[i+s._lo] proc _index2point(i:int,s:int)=[i] @@ -1585,7 +1521,6 @@ proc _index2point(i:int,s:tuple(int,5))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) proc _index2point(i:int,s:tuple(int,6))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) proc _index2point(i:int,s:tuple(int,7))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) - /* // Numeric array operations proc -(x:num^any)={ @@ -1606,7 +1541,7 @@ proc *(x:num,y:num^any)={ proc /(x:num^any,y:num)={ xx/y:xx in x } -*/ + // ***************************************** // ARRAY TEMPLATES @@ -1640,6 +1575,7 @@ proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) +*/ // *************************************************** // LOOPS AND PARALLEL STATEMENTS @@ -1668,7 +1604,7 @@ proc PM__check_task'(num)=true proc PM__chan_stmt'() yield() { yield() } proc PM__over_stmt'(x) yield() { yield() } -proc #(x)=x +proc #'(x)=x proc PM__check_iter(x){} proc PM__check_iter_amp(x){} @@ -1886,7 +1822,7 @@ proc as(x,t:)...=PM__cast(x,t) proc as(x,t)=PM__cast(x,typeof(t)) PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" proc ==(x:,y:)=x inc y and y inc x -PM__intrinsic<> error_type()->(?0) : "call" +PM__intrinsic error_type()->(=1) : "error_type" // Debugging PM__intrinsic<> _dump(any,any): "new_dump" @@ -1932,3 +1868,5 @@ proc PM__make_over'(a)=a PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_concat" PM__intrinsic<> PM__list_splice(x:PM__list,y:PM__list,i:literal(int),j:literal(int))->(=x):"list_splice" + +proc compile_error(mess:literal(string)): test mess=>false diff --git a/src/codegen.f90 b/src/codegen.f90 index 7607ae4..eb9b753 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -2192,18 +2192,15 @@ recursive subroutine make_check(coder,cblock,p,base) call make_literal_const(coder,cblock,p,node_num_arg(mess,1)) call code_null(coder) else - call make_sys_var(coder,cblock,p,sym_check,var_is_shadowed) cblock2=make_cblock(coder,cblock,p,sym_check) call trav_expr(coder,cblock2,p,mess) - call init_var(coder,cblock2,p,& - coder%vstack(coder%vtop-2)) call close_cblock(coder,cblock2) + call swap_code(coder) endif - call make_sys_var(coder,cblock,p,sym_query,var_is_shadowed) cblock3=make_cblock(coder,cblock,p,sym_check) call trav_expr(coder,cblock3,p,node_arg(p,i+1)) - call init_var(coder,cblock3,p,coder%vstack(coder%vtop-2)) call close_cblock(coder,cblock3) + call swap_code(coder) call make_sp_call(coder,cblock,p,sym_check,4,0) end do contains @@ -2732,6 +2729,17 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) else var=find_var_and_entry(coder,name,var_index) if(pm_fast_isnull(var)) then + if(.not.islhs) then + var=find_param(coder,cblock,pnode,name) + if(pm_fast_isnull(var)) then + call code_error(coder,pnode,& + 'Variable, constant or parameter has not been defined: ',name) + call make_temp_var(coder,cblock,pnode) + return + endif + call code_val(coder,var) + return + endif call code_error(coder,pnode,& 'Variable or constant has not been defined: ',name) call make_temp_var(coder,cblock,pnode) @@ -3345,7 +3353,7 @@ subroutine trav_name(coder,cblock,node,sym,name) call code_val(coder,p) endif else - call trav_ref_to_var(coder,cblock,p,name,.false.) + call trav_ref_to_var(coder,cblock,node,name,.false.) endif contains diff --git a/src/infer.f90 b/src/infer.f90 index 8ab7ec8..8f89ff6 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -617,7 +617,7 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) integer,intent(in):: atype,ptype integer:: rtype,mode,atype1 integer,dimension(1):: key - integer:: k,t1,n + integer:: k,t1,n,opcode type(pm_ptr):: tv,v logical:: isstatic,iscomm @@ -638,6 +638,13 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) endif endif + opcode=cnode_get_num(procnode,bi_opcode) + + if(opcode==op_error_type) then + rtype=error_type + return + endif + if(cnode_flags_set(procnode,pr_flags,proccall_is_comm)) then atype1=pm_type_arg(coder%context,atype,1+num_comm_args) else @@ -646,7 +653,7 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) endif ! special handling of return types for some operations - select case(cnode_get_num(procnode,bi_opcode)) + select case(opcode) case(first_fold:last_fold) rtype=fold(coder,procnode,atype,rtype) call code_num(coder,sp_sig_setval) @@ -1263,20 +1270,28 @@ subroutine inf_call(coder,cblock,callnode) endif call inf_cblock(coder,cnode_arg(args,4)) tno=arg_type(3) - if(pm_type_strip_to_basic(coder%context,arg_type(1))/=pm_string_type& - .and.arg_type(1)/=error_type) then - call inf_error_with_trace(coder,cnode_arg(args,1),& - 'Check message is not a string, got:'//& - trim(pm_type_as_string(coder%context,arg_type(1)))) - elseif(tno==coder%false_fix) then - if(cnode_get_kind(cnode_arg(args,1))==cnode_is_const) then - call pm_strval(cnode_arg(cnode_arg(args,1),1),str) - call inf_error_with_trace(coder,callnode,str(1:len_trim(str))) + if(tno==coder%false_fix.or.tno==coder%false_literal) then + tno2=pm_type_strip_mode(coder%context,arg_type(1),mode) + t=pm_type_vect(coder%context,tno2) + if(pm_tv_kind(t)==pm_type_is_literal_value) then + if(pm_tv_arg(t,1)==pm_string_type) then + call pm_strval(pm_type_val(coder%context,tno2),str) + call inf_error_with_trace(coder,callnode,str(1:len_trim(str))) + else + call inf_error_with_trace(coder,callnode,& + 'Check condition will always fail and check message is not a string') + endif else + write(*,*) '@',pm_tv_kind(t),tno2 call inf_error_with_trace(coder,callnode,& 'Check condition will always fail') endif - elseif(tno/=coder%true_fix) then + elseif(pm_type_strip_to_basic(coder%context,arg_type(1))/=pm_string_type& + .and.arg_type(1)/=error_type) then + call inf_error_with_trace(coder,cnode_arg(args,1),& + 'Check message is not a string, got:'//& + trim(pm_type_as_string(coder%context,arg_type(1)))) + elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then call check_logical(3,.false.) coder%stack(coder%base-2)=ior(coder%stack(coder%base-2),proc_is_impure) endif diff --git a/src/parser.f90 b/src/parser.f90 index 2b8d1ea..084366f 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -949,7 +949,6 @@ subroutine get_pos(parser,line,pos) pos=parser%n end subroutine get_pos - !====================================================== ! Next token must be specific token or error raised ! (moves past the token) @@ -1891,10 +1890,11 @@ recursive function term(parser,checkqual) result(iserr) call make_node(parser,sym,0) call scan(parser) endif - case(sym_true,sym_false) + case(sym_true,sym_false,sym_underscore) call make_node(parser,sym,0) call scan(parser) goto 20 + ! ** These are for internal use by the compiler only ** case(sym_caret) call scan(parser) @@ -3398,13 +3398,15 @@ end function sync_stmt !====================================================== ! List of statements !====================================================== - recursive subroutine stmt_list(parser,single) + recursive subroutine stmt_list(parser,single,num_to_include) type(parse_state),intent(inout):: parser logical,intent(in),optional:: single + integer,intent(in),optional:: num_to_include logical:: ok integer:: i,n,m,k,name,sym,label,line,pos type(pm_ptr):: p k=0 + if(present(num_to_include)) k=num_to_include do sym=parser%sym select case(sym) @@ -5362,7 +5364,10 @@ function intrinsic(parser) result(iserr) if(proc_sig(parser,iand(flags,proccall_is_comm)/=0)) return if(expect(parser,sym_colon)) goto 999 - if(expect(parser,sym_string)) goto 999 + if(parser%sym/=sym_string) then + call parse_error(parser,'Expected string operation name in "PM__intrinsic"') + goto 999 + endif p=pm_dict_lookup(parser%context,parser%op_names,& pm_type_val(parser%context,& parser%lexval)) @@ -5371,6 +5376,7 @@ function intrinsic(parser) result(iserr) pm_value_as_string(parser%context,pm_type_val(parser%context,parser%lexval))) goto 999 endif + call scan(parser) opcode=p%offset if(parser%sym==sym_open) then @@ -5892,7 +5898,7 @@ subroutine decl(parser,is_root_module) integer:: dt type(pm_ptr):: old,p integer:: m,sym,name,name2,base,top,kind,line,pos - integer:: serror + integer:: serror,num_tests logical:: ok if(.not.(parser%modl==parser%sysmodl)) then call push_sym_val(parser,sym_pm_system) @@ -5916,6 +5922,7 @@ subroutine decl(parser,is_root_module) call skip_past_error(parser,.false.) endif enddo + num_tests=0 do select case(parser%sym) case(sym_proc) @@ -5926,6 +5933,7 @@ subroutine decl(parser,is_root_module) if(param_decl(parser)) goto 999 case(sym_test) if(test_stmt(parser)) goto 999 + num_tests=num_tests+1 case(sym_pm_if_compiling) call scan(parser) if(.not.pm_is_compiling) then @@ -5958,10 +5966,13 @@ subroutine decl(parser,is_root_module) call skip_past_error(parser,.false.) enddo if(is_root_module) then - call stmt_list(parser) - elseif(parser%sym/=sym_eof) then + call stmt_list(parser,num_to_include=num_tests) + else + if(parser%sym/=sym_eof) then call parse_error(parser,& 'Library module cannot contain non-"debug" statement') + end if + call push_null_val(parser) end if if(parser%sym/=sym_eof) then call parse_error(parser,'Expected end of module') diff --git a/src/symbol.f90 b/src/symbol.f90 index 751e486..1e24720 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -972,7 +972,7 @@ module pm_symbol data sym_names(sym_dims) /'dims'/ data sym_names(sym_make_dollar) /'PM__makeidxdim'/ data sym_names(sym_make_dtuple) /'PM__makeidx'/ - data sym_names(sym_stretch_dim) /'PM__strdim'/ + data sym_names(sym_stretch_dim) /'PM__underscore'/ data sym_names(sym_pm_nhd) /'PM__nhd'/ data sym_names(sym_envelope) /'envelope'/ data sym_names(sym_set_nhd) /'PM__set_nhd'/ diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 6f83a9b..cdff052 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -729,7 +729,8 @@ module pm_vmdefs integer,parameter:: op_type_include_fold = -30 integer,parameter:: first_fold=-30 integer,parameter:: op_clone_var = -31 - integer,parameter:: min_op=op_clone_var + integer,parameter:: op_error_type = -32 + integer,parameter:: min_op=op_error_type integer,dimension(0:num_op):: op_flags integer,parameter:: op_is_call=1 @@ -2112,6 +2113,7 @@ subroutine set_op_names op_names(op_num_elems_fold)='num_elems_fold' op_names(op_type_include_fold)='type_include_fold' op_names(op_clone_var)='clone_var' + op_names(op_error_type)='error_type' !!$ do i=op_call,op_comm_loop_par !!$ if(op_names(i)=='??')then From e563cb3f351da7c21b2ec5a6b53ac3a97df16cee Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 6 Jun 2025 16:50:51 +0100 Subject: [PATCH 23/36] Finding library files --- lib/sys/pm.pmm | 1887 +++++++++++++++++++++++++++++++++++++++++++++++ src/ast.f90 | 1 + src/codegen.f90 | 9 +- src/infer.f90 | 19 +- src/lib.f90 | 4 +- src/linker.f90 | 90 ++- src/main.f90 | 95 ++- src/opts.f90 | 23 +- src/parser.f90 | 26 +- src/symbol.f90 | 8 +- src/types.f90 | 75 +- src/wcoder.f90 | 3 +- 12 files changed, 2144 insertions(+), 96 deletions(-) create mode 100644 lib/sys/pm.pmm diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm new file mode 100644 index 0000000..eedaf85 --- /dev/null +++ b/lib/sys/pm.pmm @@ -0,0 +1,1887 @@ +/* + PM (Parallel Models) Programming Language + + Released under the MIT License (MIT) + Copyright (c) Tim Bellerby, 2025 + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + + +PM__intrinsic num_elements(any)->(literal(int)) : "num_elems_fold" + +PM__intrinsic mod(literal(int),literal(int))->(literal(int)) : "mod_fold" +PM__intrinsic ==(literal(int),literal(int))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(int),literal(int))->(literal(bool)) : "ne_fold" +PM__intrinsic >=(literal(int),literal(int))->(literal(bool)) : "ge_fold" +PM__intrinsic >(literal(int),literal(int))->(literal(bool)) : "gt_fold" +PM__intrinsic +(literal(int),literal(int))->(literal(int)) : "add_fold" +PM__intrinsic -(literal(int),literal(int))->(literal(int)) : "sub_fold" +PM__intrinsic *(literal(int),literal(int))->(literal(int)) : "mult_fold" +PM__intrinsic /(literal(int),literal(int))->(literal(int)) : "divide_fold" +PM__intrinsic **(literal(int),literal(int))->(literal(int)) : "pow_fold" +PM__intrinsic max(literal(int),literal(int))->(literal(int)) : "max_fold" +PM__intrinsic min(literal(int),literal(int))->(literal(int)) : "min_fold" +PM__intrinsic -(literal(int))->(literal(int)) : "uminus_fold" +PM__intrinsic string(literal(int))->(literal(string)) : "string_fold" +PM__intrinsic abs(literal(int))->(literal(int)) : "abs_fold" +PM__intrinsic ~(literal(int))->(literal(int)) : "bnot_fold" +PM__intrinsic &(literal(int),literal(int))->(literal(int)) : "band_fold" +PM__intrinsic |(literal(int),literal(int))->(literal(int)) : "bor_fold" +PM__intrinsic ~(literal(int),literal(int))->(literal(int)) : "bxor_fold" +PM__intrinsic shift(literal(int),literal(int))->(literal(int)) : "bshift_fold" +PM__intrinsic pdiff(literal(int),literal(int))->(literal(int)) : "pdiff_fold" +PM__intrinsic sign(literal(int),literal(int))->(literal(int)) : "sign_fold" +PM__intrinsic rem(literal(int),literal(int))->(literal(int)) : "modulo_fold" +PM__intrinsic and(literal(bool),literal(bool))->(literal(bool)) : "and_fold" +PM__intrinsic or(literal(bool),literal(bool))->(literal(bool)) : "or_fold" +PM__intrinsic except(literal(bool),literal(bool))->(literal(bool)) : "except_fold" +PM__intrinsic ==(literal(bool),literal(bool))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(bool),literal(bool))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(string),literal(string))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(string),literal(string))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(real),literal(real))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(real),literal(real))->(literal(bool)) : "ne_fold" +PM__intrinsic ++(literal(string),literal(string))->(literal(string)) : "concat_fold" +PM__intrinsic mod(fix(int),fix(int))->(fix(int)) : "mod_fold" +PM__intrinsic ==(fix(int),fix(int))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(int),fix(int))->(fix(bool)) : "ne_fold" +PM__intrinsic >=(fix(int),fix(int))->(fix(bool)) : "ge_fold" +PM__intrinsic >(fix(int),fix(int))->(fix(bool)) : "gt_fold" +PM__intrinsic +(fix(int),fix(int))->(fix(int)) : "add_fold" +PM__intrinsic -(fix(int),fix(int))->(fix(int)) : "sub_fold" +PM__intrinsic *(fix(int),fix(int))->(fix(int)) : "mult_fold" +PM__intrinsic /(fix(int),fix(int))->(fix(int)) : "divide_fold" +PM__intrinsic **(fix(int),fix(int))->(fix(int)) : "pow_fold" +PM__intrinsic max(fix(int),fix(int))->(fix(int)) : "max_fold" +PM__intrinsic min(fix(int),fix(int))->(fix(int)) : "min_fold" +PM__intrinsic -(fix(int))->(fix(int)) : "uminus_fold" +PM__intrinsic string(fix(int))->(fix(string)) : "string_fold" +PM__intrinsic abs(fix(int))->(fix(int)) : "abs_fold" +PM__intrinsic ~(fix(int))->(fix(int)) : "bnot_fold" +PM__intrinsic &(fix(int),fix(int))->(fix(int)) : "band_fold" +PM__intrinsic |(fix(int),fix(int))->(fix(int)) : "bor_fold" +PM__intrinsic ~(fix(int),fix(int))->(fix(int)) : "bxor_fold" +PM__intrinsic shift(fix(int),fix(int))->(fix(int)) : "bshift_fold" +PM__intrinsic pdiff(fix(int),fix(int))->(fix(int)) : "pdiff_fold" +PM__intrinsic sign(fix(int),fix(int))->(fix(int)) : "sign_fold" +PM__intrinsic rem(fix(int),fix(int))->(fix(int)) : "modulo_fold" +PM__intrinsic and(fix(bool),fix(bool))->(fix(bool)) : "and_fold" +PM__intrinsic or(fix(bool),fix(bool))->(fix(bool)) : "or_fold" +PM__intrinsic except(fix(bool),fix(bool))->(fix(bool)) : "except_fold" +PM__intrinsic ==(fix(bool),fix(bool))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(bool),fix(bool))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(string),fix(string))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(string),fix(string))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(real),fix(real))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(real),fix(real))->(fix(bool)) : "ne_fold" +PM__intrinsic ++(fix(string),fix(string))->(fix(string)) : "concat_fold" + +// ************************************** +// BASIC TYPES +// ************************************** + +// String type +PM__intrinsic<> print(string): "print" + +proc print(x) { + print(string(x)) +} + +PM__intrinsic<> print_all(string): "print"(1) + +proc print_all(x) { + print_all(string(x)) +} + +PM__intrinsic ++(string,string)->(string) : "concat" + +proc ++(x:string,y)=$++.(x,string(y)) +proc ++(x,y)=$++.(string(x),string(y)) +proc string(x:string)=x +proc string(x:null)="null" +proc fmt(x,y)=x:compile_error( """fmt"" operator not yet implmented") + +// sint type +PM__intrinsic PM__assign_var(&sint,sint): "assign_i" +PM__intrinsic mod(sint,sint)->(sint) : "mod_i" +PM__intrinsic ==(sint,sint)->(bool) : "eq_i" +PM__intrinsic /=(sint,sint)->(bool) : "ne_i" +PM__intrinsic >=(sint,sint)->(bool) : "ge_i" +PM__intrinsic >(sint,sint)->(bool) : "gt_i" +PM__intrinsic +(sint,sint)->(sint) : "add_i" +PM__intrinsic -(sint,sint)->(sint) : "sub_i" +PM__intrinsic *(sint,sint)->(sint) : "mult_i" +PM__intrinsic /(sint,sint)->(sint) : "divide_i" +PM__intrinsic **(sint,sint)->(sint) : "pow_i" +PM__intrinsic max(sint,sint)->(sint) : "max_i" +PM__intrinsic min(sint,sint)->(sint) : "min_i" +PM__intrinsic -(sint)->(sint) : "uminus_i" +PM__intrinsic string(sint)->(string) : "string_i" +PM__intrinsic int(sint)->(int) : "long_i" +PM__intrinsic sreal(sint)->(sreal) : "real_i" +PM__intrinsic real(sint)->(real) : "double_i" +proc sint(x:sint)=x +PM__intrinsic abs(sint)->(sint) : "abs_i" +PM__intrinsic bit_not(sint)->(sint) : "bnot_i" +PM__intrinsic &(sint,sint)->(sint) : "band_i" +PM__intrinsic |(sint,sint)->(sint) : "bor_i" +PM__intrinsic ~(sint,sint)->(sint) : "bxor_i" +PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" +PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" +PM__intrinsic sign(sint,sint)->(sint) : "sign_i" +PM__intrinsic rem(sint,sint)->(sint) : "modulo_i" +PM__intrinsic int8(sint)->(int8) : "i8_i" +PM__intrinsic int16(sint)->(int16) : "i16_i" +PM__intrinsic int32(sint)->(int32) : "i32_i" +PM__intrinsic int64(sint)->(int64) : "i64_i" +PM__intrinsic lint(sint)->(lint) : "offset_i" + +// int type +PM__intrinsic PM__assign_var(&int,int): "assign_ln" +PM__intrinsic mod(int,int)->(int) : "mod_ln" +PM__intrinsic ==(int,int)->(bool) : "eq_ln" +PM__intrinsic /=(int,int)->(bool) : "ne_ln" +PM__intrinsic >=(int,int)->(bool) : "ge_ln" +PM__intrinsic >(int,int)->(bool) : "gt_ln" +PM__intrinsic +(int,int)->(int) : "add_ln" +PM__intrinsic -(int,int)->(int) : "sub_ln" +PM__intrinsic *(int,int)->(int) : "mult_ln" +proc *(x:int,y:fix(1))=x +PM__intrinsic /(int,int)->(int) : "divide_ln" +proc /(x:int,y:fix(1))=x +PM__intrinsic **(int,int)->(int) : "pow_ln" +PM__intrinsic max(int,int)->(int) : "max_ln" +PM__intrinsic min(int,int)->(int) : "min_ln" +PM__intrinsic -(int)->(int) : "uminus_ln" +PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic sint(int)->(sint) : "int_ln" +PM__intrinsic sreal(int)->(sreal) : "real_ln" +PM__intrinsic real(int)->(real) : "double_ln" +proc int(x:int)=x +PM__intrinsic abs(int)->(int) : "abs_ln" +PM__intrinsic ~(int)->(int) : "bnot_ln" +PM__intrinsic &(int,int)->(int) : "band_ln" +PM__intrinsic |(int,int)->(int) : "bor_ln" +PM__intrinsic ~(int,int)->(int) : "bxor_ln" +PM__intrinsic shift(int,int)->(int) : "bshift_ln" +PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" +PM__intrinsic sign(int,int)->(int) : "sign_ln" +PM__intrinsic rem(int,int)->(int) : "modulo_ln" +PM__intrinsic int8(int)->(int8) : "i8_ln" +PM__intrinsic int16(int)->(int16) : "i16_ln" +PM__intrinsic int32(int)->(int32) : "i32_ln" +PM__intrinsic int64(int)->(int64) : "i64_ln" +PM__intrinsic lint(int)->(lint) : "offset_ln" + +// lint type +PM__intrinsic PM__assign_var(&lint,lint): "assign_offset" +PM__intrinsic mod(lint,lint)->(lint) : "mod_offset" +PM__intrinsic ==(lint,lint)->(bool) : "eq_offset" +PM__intrinsic /=(lint,lint)->(bool) : "ne_offset" +PM__intrinsic >=(lint,lint)->(bool) : "ge_offset" +PM__intrinsic >(lint,lint)->(bool) : "gt_offset" +PM__intrinsic +(lint,lint)->(lint) : "add_offset" +proc +(x:lint,y:fix(0))=x +proc +(x:fix(0),y:lint)=y +PM__intrinsic -(lint,lint)->(lint) : "sub_offset" +proc -(x:lint,y:fix(0))=x +PM__intrinsic *(lint,lint)->(lint) : "mult_offset" +proc *(x:lint,y:fix(1))=x +proc *(x:fix(1),y:lint)=y +PM__intrinsic /(lint,lint)->(lint) : "divide_offset" +proc /(x:lint,y:fix(1))=x +PM__intrinsic **(lint,lint)->(lint) : "pow_offset" +proc **(x:lint,y:fix(0))=1 +proc **(x:lint,y:fix(1))=x +proc **(x:lint,y:fix(2))=x*x +PM__intrinsic max(lint,lint)->(lint) : "max_offset" +PM__intrinsic min(lint,lint)->(lint) : "min_offset" +PM__intrinsic -(lint)->(lint) : "uminus_offset" +PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic sint(lint)->(sint) : "int_offset" +PM__intrinsic sreal(lint)->(sreal) : "real_offset" +PM__intrinsic real(lint)->(real) : "double_offset" +proc lint(x:lint)=x +PM__intrinsic abs(lint)->(lint) : "abs_offset" +PM__intrinsic ~(lint)->(lint) : "bnot_offset" +PM__intrinsic &(lint,lint)->(lint) : "band_offset" +PM__intrinsic |(lint,lint)->(lint) : "bor_offset" +PM__intrinsic ~(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" +PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" +PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" +PM__intrinsic rem(lint,lint)->(lint) : "modulo_offset" +PM__intrinsic int8(lint)->(int8) : "i8_offset" +PM__intrinsic int16(lint)->(int16) : "i16_offset" +PM__intrinsic int32(lint)->(int32) : "i32_offset" +PM__intrinsic int64(lint)->(int64) : "i64_offset" +PM__intrinsic int(lint)->(int) : "long_offset" + +// int8 type +PM__intrinsic PM__assign_var(&int8,int8): "assign_i8" +PM__intrinsic mod(int8,int8)->(int8) : "mod_i8" +PM__intrinsic ==(int8,int8)->(bool) : "eq_i8" +PM__intrinsic /=(int8,int8)->(bool) : "ne_i8" +PM__intrinsic >=(int8,int8)->(bool) : "ge_i8" +PM__intrinsic >(int8,int8)->(bool) : "gt_i8" +PM__intrinsic +(int8,int8)->(int8) : "add_i8" +proc +(x:int8,y:fix(0))=x +proc +(x:fix(0),y:int8)=y +PM__intrinsic -(int8,int8)->(int8) : "sub_i8" +proc -(x:int8,y:fix(0))=x +PM__intrinsic *(int8,int8)->(int8) : "mult_i8" +proc *(x:int8,y:fix(1))=x +proc *(x:fix(1),y:int8)=y +PM__intrinsic /(int8,int8)->(int8) : "divide_i8" +proc /(x:int8,y:fix(1))=x +PM__intrinsic **(int8,int8)->(int8) : "pow_i8" +proc **(x:int8,y:fix(0))=1 +proc **(x:int8,y:fix(1))=x +proc **(x:int8,y:fix(2))=x*x +PM__intrinsic max(int8,int8)->(int8) : "max_i8" +PM__intrinsic min(int8,int8)->(int8) : "min_i8" +PM__intrinsic -(int8)->(int8) : "uminus_i8" +PM__intrinsic sint(int8)->(sint) : "int_i8" +PM__intrinsic sreal(int8)->(sreal) : "real_i8" +PM__intrinsic real(int8)->(real) : "double_i8" +proc int8(x:int8)=x +PM__intrinsic abs(int8)->(int8) : "abs_i8" +PM__intrinsic ~(int8)->(int8) : "bnot_i8" +PM__intrinsic &(int8,int8)->(int8) : "band_i8" +PM__intrinsic |(int8,int8)->(int8) : "bor_i8" +PM__intrinsic ~(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" +PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" +PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" +PM__intrinsic rem(int8,int8)->(int8) : "modulo_i8" +PM__intrinsic int16(int8)->(int16) : "i16_i8" +PM__intrinsic int32(int8)->(int32) : "i32_i8" +PM__intrinsic int64(int8)->(int64) : "i64_i8" +PM__intrinsic int(int8)->(int) : "long_i8" +PM__intrinsic lint(int8)->(lint) : "offset_i8" + +// int16 type +PM__intrinsic PM__assign_var(&int16,int16): "assign_i16" +PM__intrinsic mod(int16,int16)->(int16) : "mod_i16" +PM__intrinsic ==(int16,int16)->(bool) : "eq_i16" +PM__intrinsic /=(int16,int16)->(bool) : "ne_i16" +PM__intrinsic >=(int16,int16)->(bool) : "ge_i16" +PM__intrinsic >(int16,int16)->(bool) : "gt_i16" +PM__intrinsic +(int16,int16)->(int16) : "add_i16" +proc +(x:int16,y:fix(0))=x +proc +(x:fix(0),y:int16)=y +PM__intrinsic -(int16,int16)->(int16) : "sub_i16" +proc -(x:int16,y:fix(0))=x +PM__intrinsic *(int16,int16)->(int16) : "mult_i16" +proc *(x:int16,y:fix(1))=x +proc *(x:fix(1),y:int16)=y +PM__intrinsic /(int16,int16)->(int16) : "divide_i16" +proc /(x:int16,y:fix(1))=x +PM__intrinsic **(int16,int16)->(int16) : "pow_i16" +proc **(x:int16,y:fix(0))=1 +proc **(x:int16,y:fix(1))=x +proc **(x:int16,y:fix(2))=x*x +PM__intrinsic max(int16,int16)->(int16) : "max_i16" +PM__intrinsic min(int16,int16)->(int16) : "min_i16" +PM__intrinsic -(int16)->(int16) : "uminus_i16" +PM__intrinsic sint(int16)->(sint) : "int_i16" +PM__intrinsic sreal(int16)->(sreal) : "real_i16" +PM__intrinsic real(int16)->(real) : "double_i16" +proc int16(x:int16)=x +PM__intrinsic abs(int16)->(int16) : "abs_i16" +PM__intrinsic ~(int16)->(int16) : "bnot_i16" +PM__intrinsic &(int16,int16)->(int16) : "band_i16" +PM__intrinsic |(int16,int16)->(int16) : "bor_i16" +PM__intrinsic ~(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" +PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" +PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" +PM__intrinsic rem(int16,int16)->(int16) : "modulo_i16" +PM__intrinsic int8(int16)->(int16) : "i8_i16" +PM__intrinsic int32(int16)->(int32) : "i32_i16" +PM__intrinsic int64(int16)->(int64) : "i64_i16" +PM__intrinsic int(int16)->(int) : "long_i16" +PM__intrinsic lint(int16)->(lint) : "offset_i16" + +// int32 type +PM__intrinsic PM__assign_var(&int32,int32): "assign_i32" +PM__intrinsic mod(int32,int32)->(int32) : "mod_i32" +PM__intrinsic ==(int32,int32)->(bool) : "eq_i32" +PM__intrinsic /=(int32,int32)->(bool) : "ne_i32" +PM__intrinsic >=(int32,int32)->(bool) : "ge_i32" +PM__intrinsic >(int32,int32)->(bool) : "gt_i32" +PM__intrinsic +(int32,int32)->(int32) : "add_i32" +proc +(x:int32,y:fix(0))=x +proc +(x:fix(0),y:int32)=y +PM__intrinsic -(int32,int32)->(int32) : "sub_i32" +proc -(x:int32,y:fix(0))=x +PM__intrinsic *(int32,int32)->(int32) : "mult_i32" +proc *(x:int32,y:fix(1))=x +proc *(x:fix(1),y:int32)=y +PM__intrinsic /(int32,int32)->(int32) : "divide_i32" +proc /(x:int32,y:fix(1))=x +PM__intrinsic **(int32,int32)->(int32) : "pow_i32" +proc **(x:int32,y:fix(0))=1 +proc **(x:int32,y:fix(1))=x +proc **(x:int32,y:fix(2))=x*x +PM__intrinsic max(int32,int32)->(int32) : "max_i32" +PM__intrinsic min(int32,int32)->(int32) : "min_i32" +PM__intrinsic -(int32)->(int32) : "uminus_i32" +PM__intrinsic sint(int32)->(sint) : "int_i32" +PM__intrinsic sreal(int32)->(sreal) : "real_i32" +PM__intrinsic real(int32)->(real) : "double_i32" +proc int32(x:int32)=x +PM__intrinsic abs(int32)->(int32) : "abs_i32" +PM__intrinsic ~(int32)->(int32) : "bnot_i32" +PM__intrinsic &(int32,int32)->(int32) : "band_i32" +PM__intrinsic |(int32,int32)->(int32) : "bor_i32" +PM__intrinsic ~(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" +PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" +PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" +PM__intrinsic rem(int32,int32)->(int32) : "modulo_i32" +PM__intrinsic int8(int32)->(int32) : "i8_i32" +PM__intrinsic int16(int32)->(int32) : "i16_i32" +PM__intrinsic int64(int32)->(int64) : "i64_i32" +PM__intrinsic int(int32)->(int) : "long_i32" +PM__intrinsic lint(int32)->(lint) : "offset_i32" + +// int64 type +PM__intrinsic PM__assign_var(&int64,int64): "assign_i64" +PM__intrinsic mod(int64,int64)->(int64) : "mod_i64" +PM__intrinsic ==(int64,int64)->(bool) : "eq_i64" +PM__intrinsic /=(int64,int64)->(bool) : "ne_i64" +PM__intrinsic >=(int64,int64)->(bool) : "ge_i64" +PM__intrinsic >(int64,int64)->(bool) : "gt_i64" +PM__intrinsic +(int64,int64)->(int64) : "add_i64" +proc +(x:int64,y:fix(0))=x +proc +(x:fix(0),y:int64)=y +PM__intrinsic -(int64,int64)->(int64) : "sub_i64" +proc -(x:int64,y:fix(0))=x +PM__intrinsic *(int64,int64)->(int64) : "mult_i64" +proc *(x:int64,y:fix(1))=x +proc *(x:fix(1),y:int64)=y +PM__intrinsic /(int64,int64)->(int64) : "divide_i64" +proc /(x:int64,y:fix(1))=x +PM__intrinsic **(int64,int64)->(int64) : "pow_i64" +proc **(x:int64,y:fix(0))=1 +proc **(x:int64,y:fix(1))=x +proc **(x:int64,y:fix(2))=x*x +PM__intrinsic max(int64,int64)->(int64) : "max_i64" +PM__intrinsic min(int64,int64)->(int64) : "min_i64" +PM__intrinsic -(int64)->(int64) : "uminus_i64" +PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic sint(int64)->(sint) : "int_i64" +PM__intrinsic sreal(int64)->(sreal) : "real_i64" +PM__intrinsic real(int64)->(real) : "double_i64" +proc int64(x:int64)=x +PM__intrinsic abs(int64)->(int64) : "abs_i64" +PM__intrinsic ~(int64)->(int64) : "bnot_i64" +PM__intrinsic &(int64,int64)->(int64) : "band_i64" +PM__intrinsic |(int64,int64)->(int64) : "bor_i64" +PM__intrinsic ~(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" +PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" +PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" +PM__intrinsic rem(int64,int64)->(int64) : "modulo_i64" +PM__intrinsic int8(int64)->(int64) : "i8_i64" +PM__intrinsic int16(int64)->(int64) : "i16_i64" +PM__intrinsic int32(int64)->(int64) : "i32_i64" +PM__intrinsic int(int64)->(int) : "long_i64" +PM__intrinsic lint(int64)->(lint) : "offset_i64" + +// sreal type +PM__intrinsic PM__assign_var(&sreal,sreal): "assign_r" +PM__intrinsic mod(sreal,sreal)->(sreal) : "mod_r" +PM__intrinsic ==(sreal,sreal)->(bool) : "eq_r" +PM__intrinsic /=(sreal,sreal)->(bool) : "ne_r" +PM__intrinsic >=(sreal,sreal)->(bool) : "ge_r" +PM__intrinsic >(sreal,sreal)->(bool) : "gt_r" +PM__intrinsic +(sreal,sreal)->(sreal) : "add_r" +PM__intrinsic -(sreal,sreal)->(sreal) : "sub_r" +PM__intrinsic *(sreal,sreal)->(sreal) : "mult_r" +PM__intrinsic /(sreal,sreal)->(sreal) : "divide_r" +PM__intrinsic **(sreal,sreal)->(sreal) : "pow_r" +PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" +PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" +PM__intrinsic -(sreal)->(sreal) : "uminus_r" +PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic strunc(sreal)->(sint) : "int_r" +PM__intrinsic trunc(sreal)->(int) : "long_r" +PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" +PM__intrinsic real(sreal)->(real) : "double_r" +proc sreal(x:sreal)=x +PM__intrinsic abs(sreal)->(sreal) : "abs_r" +PM__intrinsic acos(sreal)->(sreal) : "acos_r" +PM__intrinsic asin(sreal)->(sreal) : "asin_r" +PM__intrinsic atan(sreal)->(sreal) : "atan_r" +PM__intrinsic atan2(sreal,sreal)->(sreal) : "atan2_r" +PM__intrinsic cos(sreal)->(sreal) : "cos_r" +PM__intrinsic cosh(sreal)->(sreal) : "cosh_r" +PM__intrinsic exp(sreal)->(sreal) : "exp_r" +PM__intrinsic log(sreal)->(sreal) : "log_r" +PM__intrinsic log10(sreal)->(sreal) : "log10_r" +PM__intrinsic sin(sreal)->(sreal) : "sin_r" +PM__intrinsic sinh(sreal)->(sreal) : "sinh_r" +PM__intrinsic sqrt(sreal)->(sreal) : "sqrt_r" +PM__intrinsic tan(sreal)->(sreal) : "tan_r" +PM__intrinsic tanh(sreal)->(sreal) : "tanh_r" +PM__intrinsic floor(sreal)->(sreal) : "floor_r" +PM__intrinsic ceil(sreal)->(sreal) : "ceil_r" +PM__intrinsic rem(sreal,sreal)->(sreal) : "modulo_r" +PM__intrinsic sign(sreal,sreal)->(sreal) : "sign_r" +PM__intrinsic pdiff(sreal,sreal)->(sreal) : "pdiff_r" +PM__intrinsic lint(sreal)->(lint) : "offset_r" +PM__intrinsic scpx(sreal)->(scpx) : "complex_r" +PM__intrinsic _scpx2(sreal,sreal)->(scpx) : "complex2_r" +proc scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y)) + +// real type +PM__intrinsic PM__assign_var(&real,real): "assign_d" +PM__intrinsic mod(real,real)->(real) : "mod_d" +PM__intrinsic ==(real,real)->(bool) : "eq_d" +PM__intrinsic /=(real,real)->(bool) : "ne_d" +PM__intrinsic >=(real,real)->(bool) : "ge_d" +PM__intrinsic >(real,real)->(bool) : "gt_d" +PM__intrinsic +(real,real)->(real) : "add_d" +PM__intrinsic -(real,real)->(real) : "sub_d" +PM__intrinsic *(real,real)->(real) : "mult_d" +PM__intrinsic /(real,real)->(real) : "divide_d" +PM__intrinsic **(real,real)->(real) : "pow_d" +PM__intrinsic max(real,real)->(real) : "max_d" +PM__intrinsic min(real,real)->(real) : "min_d" +PM__intrinsic -(real)->(real) : "uminus_d" +PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic strunc(real)->(sint) : "int_d" +PM__intrinsic trunc(real)->(int) : "long_d" +PM__intrinsic ltrunc(real)->(lint) : "offset_d" +PM__intrinsic sreal(real)->(sreal) : "real_d" +proc real(x:real)=x +PM__intrinsic abs(real)->(real) : "abs_d" +PM__intrinsic acos(real)->(real) : "acos_d" +PM__intrinsic asin(real)->(real) : "asin_d" +PM__intrinsic atan(real)->(real) : "atan_d" +PM__intrinsic atan2(real,real)->(real) : "atan2_d" +PM__intrinsic cos(real)->(real) : "cos_d" +PM__intrinsic cosh(real)->(real) : "cosh_d" +PM__intrinsic exp(real)->(real) : "exp_d" +PM__intrinsic log(real)->(real) : "log_d" +PM__intrinsic log10(real)->(real) : "log10_d" +PM__intrinsic sin(real)->(real) : "sin_d" +PM__intrinsic sinh(real)->(real) : "sinh_d" +PM__intrinsic sqrt(real)->(real) : "sqrt_d" +PM__intrinsic tan(real)->(real) : "tan_d" +PM__intrinsic tanh(real)->(real) : "tanh_d" +PM__intrinsic floor(real)->(real) : "floor_d" +PM__intrinsic ceil(real)->(real) : "ceil_d" +PM__intrinsic rem(real,real)->(real) : "modulo_d" +PM__intrinsic sign(real,real)->(real) : "sign_d" +PM__intrinsic pdiff(real,real)->(real) : "pdiff_d" +PM__intrinsic lint(real)->(lint) : "offset_d" +PM__intrinsic cpx(real)->(cpx) : "complex_d" +PM__intrinsic _cpx2(real,real)->(cpx) : "complex2_d" +proc cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y)) + +// scpx type +PM__intrinsic PM__assign_var(&scpx,scpx): "assign_c" +PM__intrinsic +(scpx,scpx)->(scpx) : "add_c" +PM__intrinsic -(scpx,scpx)->(scpx) : "sub_c" +PM__intrinsic *(scpx,scpx)->(scpx) : "mult_c" +PM__intrinsic /(scpx,scpx)->(scpx) : "divide_c" +PM__intrinsic **(scpx,sreal)->(scpx) : "rpow_c" +PM__intrinsic **(scpx,scpx)->(scpx) : "pow_c" +PM__intrinsic -(scpx)->(scpx) : "uminus_c" +PM__intrinsic ==(scpx,scpx)->(bool) : "eq_c" +PM__intrinsic /=(scpx,scpx)->(bool) : "ne_c" +PM__intrinsic re(scpx)->(sreal) : "real_c" +PM__intrinsic abs(scpx)->(scpx) : "abs_c" +PM__intrinsic acos(scpx)->(scpx) : "acos_c" +PM__intrinsic asin(scpx)->(scpx) : "asin_c" +PM__intrinsic atan(scpx)->(scpx) : "atan_c" +PM__intrinsic atan2(scpx,scpx)->(scpx) : "atan2_c" +PM__intrinsic cos(scpx)->(scpx) : "cos_c" +PM__intrinsic cosh(scpx)->(scpx) : "cosh_c" +PM__intrinsic exp(scpx)->(scpx) : "exp_c" +PM__intrinsic log(scpx)->(scpx) : "log_c" +PM__intrinsic sin(scpx)->(scpx) : "sin_c" +PM__intrinsic sinh(scpx)->(scpx) : "sinh_c" +PM__intrinsic sqrt(scpx)->(scpx) : "sqrt_c" +PM__intrinsic tan(scpx)->(scpx) : "tan_c" +PM__intrinsic tanh(scpx)->(scpx) : "tanh_c" +PM__intrinsic im(scpx)->(sreal) : "imag_c" +PM__intrinsic conj(scpx)->(scpx) : "conj_c" + +// cpx type +PM__intrinsic PM__assign_var(&cpx,cpx): "assign_dc" +PM__intrinsic +(cpx,cpx)->(cpx) : "add_dc" +PM__intrinsic -(cpx,cpx)->(cpx) : "sub_dc" +PM__intrinsic *(cpx,cpx)->(cpx) : "mult_dc" +PM__intrinsic /(cpx,cpx)->(cpx) : "divide_dc" +PM__intrinsic **(cpx,real)->(cpx) : "dpow_dc" +proc **(x:cpx,y:sreal)=x**real(y) +PM__intrinsic **(cpx,cpx)->(cpx) : "pow_dc" +PM__intrinsic -(cpx)->(cpx) : "uminus_dc" +PM__intrinsic ==(cpx,cpx)->(bool) : "eq_dc" +PM__intrinsic /=(cpx,cpx)->(bool) : "ne_dc" +PM__intrinsic re(cpx)->(real) : "real_dc" +PM__intrinsic abs(cpx)->(cpx) : "abs_dc" +PM__intrinsic acos(cpx)->(cpx) : "acos_dc" +PM__intrinsic asin(cpx)->(cpx) : "asin_dc" +PM__intrinsic atan(cpx)->(cpx) : "atan_dc" +PM__intrinsic atan2(cpx,cpx)->(cpx) : "atan2_dc" +PM__intrinsic cos(cpx)->(cpx) : "cos_dc" +PM__intrinsic cosh(cpx)->(cpx) : "cosh_dc" +PM__intrinsic exp(cpx)->(cpx) : "exp_dc" +PM__intrinsic log(cpx)->(cpx) : "log_dc" +PM__intrinsic sin(cpx)->(cpx) : "sin_dc" +PM__intrinsic sinh(cpx)->(cpx) : "sinh_dc" +PM__intrinsic sqrt(cpx)->(cpx) : "sqrt_dc" +PM__intrinsic tan(cpx)->(cpx) : "tan_dc" +PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" +PM__intrinsic im(cpx)->(real) : "imag_dc" +PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + +// Cannot convert real to int (must use nint or trunc) +proc sint(x:any_real)=sint(0) :compile_error("Cannot convert real to integer") +proc int(x:any_real)=0 :compile_error("Cannot convert real to integer") +proc lint(x:any_real)=lint(0) :compile_error("Cannot convert real to integer") + +// Some numeric conversions not hard-coded +proc cpx(x:real_num)=cpx(real(x)) +proc scpx(x:real_num)=cpx(sreal(x)) +proc string(x:any_int)=string(int64(x)) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc int(x:fix(int))=x + + +// Abstract numeric types +type any_int is sint,int,lint,int8,int16,int32,int64 +type any_real is sreal,real +type any_cpx is scpx,cpx +type int_num is any_int +type real_num is int_num, any_real +type cpx_num is real_num,any_cpx +type num is cpx_num + +// Numeric type conversion +proc convert(x,y)=x +proc convert(x:int_num,y:sint)=sint(x) +proc convert(x:int_num,y:int)=int(x) +proc convert(x:int_num,y:lint)=lint(x) +proc convert(x:int_num,y:int8)=int8(x) +proc convert(x:int_num,y:int16)=int16(x) +proc convert(x:int_num,y:int32)=int32(x) +proc convert(x:int_num,y:int64)=int64(x) +proc convert(x:int_num,y:sreal)=sreal(x) +proc convert(x:int_num,y:real)=real(x) +proc convert(x:real_num,y:cpx)=cpx(x) +proc convert(x:real_num,y:scpx)=scpx(x) +proc as(x:int_num,y:)=sint(x) +proc as(x:int_num,y:)=int(x) +proc as(x:int_num,y:)=lint(x) +proc as(x:int_num,y:)=int8(x) +proc as(x:int_num,y:)=int16(x) +proc as(x:int_num,y:)=int32(x) +proc as(x:int_num,y:)=int64(x) +proc as(x:real_num,y:)=sreal(x) +proc as(x:real_num,y:)=real(x) +proc as(x:real_num,y:)=scpx(x) +proc as(x:real_num,y:)=cpx(x) + +// Auto-conversion on assignment +proc PM__assign(&x:num,y:num) { + _assign_element(&x,convert(y,x)) +} + +proc PM__assign_var(&x:num,y:num) { + PM__assign(&x,convert(y,x)) +} + +// Mixed arithmatic +type _to_sint is int +type _to_lint is sint,int +type _to_int8 is sint,int,lint +type _to_int16 is sint,int,lint,int8 +type _to_int32 is sint,int,lint,int8,int16 +type _to_int64 is sint,int,lint,int8,int16,int32 +type _to_real is any_int +type _to_sreal is any_int,real +type _to_cpx is real_num +type _to_scpx is real_num,cpx +proc balance(x:sint,y:sint)=x,y +proc balance(x:int,y:int)=x,y +proc balance(x:lint,y:lint)=x,y +proc balance(x:int8,y:int8)=x,y +proc balance(x:int16,y:int16)=x,y +proc balance(x:int32,y:int32)=x,y +proc balance(x:int64,y:int64)=x,y +proc balance(x:sreal,y:sreal)=x,y +proc balance(x:real,y:real)=x,y +proc balance(x:scpx,y:scpx)=x,y +proc balance(x:cpx,y:cpx)=x,y +proc balance(x:sint,y:_to_sint)=x,sint(y) +proc balance(x:lint,y:_to_lint)=x,lint(y) +proc balance(x:int8,y:_to_int8)=x,int8(y) +proc balance(x:int16,y:_to_int16)=x,int16(y) +proc balance(x:int32,y:_to_int32)=x,int32(y) +proc balance(x:int64,y:_to_int64)=x,int64(y) +proc balance(x:sreal,y:_to_sreal)=x,sreal(y) +proc balance(x:real,y:_to_real)=x,real(y) +proc balance(x:scpx,y:_to_scpx)=x,scpx(y) +proc balance(x:cpx,y:_to_cpx)=x,cpx(y) +proc balance(x:_to_sint,y:sint)=sint(x),y +proc balance(x:_to_lint,y:lint)=lint(x),y +proc balance(x:_to_int8,y:int8)=int8(x),y +proc balance(x:_to_int16,y:int16)=int16(x),y +proc balance(x:_to_int32,y:int32)=int32(x),y +proc balance(x:_to_int64,y:int64)=int64(x),y +proc balance(x:_to_sreal,y:sreal)=sreal(x),y +proc balance(x:_to_real,y:real)=real(x),y +proc balance(x:_to_scpx,y:scpx)=scpx(x),y +proc balance(x:_to_cpx,y:cpx)=cpx(x),y +proc div(x:any_int,y:any_int)=if(sz=>r,-1-r) where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))where sz=sign(x,y)==x +proc _divz(x:any_int,y:any_int)=z { + var z,_=balance(x,y) + if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y) +} +proc mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y) +proc ==(x:num,y:num)=xx==yy where xx,yy=balance(x,y) +proc /=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y) +proc >=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y) +proc >(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y) +proc +(x:num,y:num)=xx+yy where xx,yy=balance(x,y) +proc -(x:num,y:num)=xx-yy where xx,yy=balance(x,y) +proc *(x:num,y:num)=xx*yy where xx,yy=balance(x,y) +proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) +proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) +proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) +proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) +proc ~(x:num,y:num)=xx ~ yy where xx,yy=balance(x,y) +proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) +proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) +proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) + +// Indexed arithmetic +proc +'(x,y)=$+.(x,y) +proc -'(x,y)=$-.(x,y) +proc *'(x,y)=$*.(x,y) +proc /'(x,y)=$/.(x,y) +proc -'(x)=$-.(x) + +// bool type +PM__intrinsic PM__assign_var(&bool,bool): "assign_l" +PM__intrinsic string(bool)->(string) : "string_l" +PM__intrinsic and(bool,bool)->(bool) : "and" +PM__intrinsic or(bool,bool)->(bool) : "or" +PM__intrinsic not(bool)->(bool) : "not" +PM__intrinsic ==(bool,bool)->(bool) : "eq_l" +PM__intrinsic /=(bool,bool)->(bool) : "ne_l" + + +// val function having null effect +proc val(x)=x + + +// ******************************************** +// TUPLES +// ******************************************** + +// Tuple types + +type tuple1d(t1,r:1) is rec {PM__d1:t1,_r:r} +type tuple2d(t1,t2,r:2) is rec {PM__d1:t1,PM__d2:t2,_r:r} +type tuple3d(t1,t2,t3,r:3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,_r:r} +type tuple4d(t1,t2,t3,t4,r:4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,_r:r} +type tuple5d(t1,t2,t3,t4,t5,r:5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,_r:r} +type tuple6d(t1,t2,t3,t4,t5,t6,r:6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,_r:r} +type tuple7d(t1,t2,t3,t4,t5,t6,t7,r:7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7,_r:r} + +type dimension_number is 1,2,3,4,5,6,7 +type tuple(t,r:dimension_number) +type tuple(t,r:1) is ...,tuple1d(t,r) +type tuple(t,r:2) is ...,tuple2d(t,t,r) +type tuple(t,r:3) is ...,tuple3d(t,t,t,r) +type tuple(t,r:4) is ...,tuple4d(t,t,t,t,r) +type tuple(t,r:5) is ...,tuple5d(t,t,t,t,t,r) +type tuple(t,r:6) is ...,tuple6d(t,t,t,t,t,t,r) +type tuple(t,r:7) is ...,tuple7d(t,t,t,t,t,t,t,r) + +proc tuple(x)=rec tuple1d { + PM__d1=x,_r=1 +} +proc tuple(x,y)=rec tuple2d { + PM__d1=x,PM__d2=y,_r=2 +} +proc tuple(x,y,z)=rec tuple3d { + PM__d1=x,PM__d2=y,PM__d3=z,_r=3 +} +proc tuple(x,y,z,t)=rec tuple4d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,_r=4 +} +proc tuple(x,y,z,t,u)=rec tuple5d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,_r=5 +} +proc tuple(x,y,z,t,u,v)=rec tuple6d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,_r=6 +} +proc tuple(x,y,z,t,u,v,w)=rec tuple7d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w,_r=7 +} + +proc dim(t:tuple1d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple3d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple4d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple5d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple6d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple7d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple4d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple5d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple6d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple7d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple5d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple6d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple7d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple6d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple7d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple7d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(7) or [literal(7)])=t.7 + +proc indices(x:tuple1d)=[literal(1)] +proc indices(x:tuple2d)=[literal(1),literal(2)] +proc indices(x:tuple3d)=[literal(1),literal(2),literal(3)] +proc indices(x:tuple4d)=[literal(1),literal(2),literal(3),literal(4)] +proc indices(x:tuple5d)=[literal(1),literal(2),literal(3),literal(4),literal(5)] +proc indices(x:tuple6d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6)] +proc indices(x:tuple7d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6),literal(7)] + +proc full_rank(x:tuple1d)=1 +proc full_rank(x:tuple2d)=2 +proc full_rank(x:tuple3d)=3 +proc full_rank(x:tuple4d)=4 +proc full_rank(x:tuple5d)=5 +proc full_rank(x:tuple6d)=6 +proc full_rank(x:tuple7d)=7 +proc rank(x:tuple)=full_rank(x) + +proc reduce(p:proc,x:tuple1d)=x.1 +proc reduce(p:proc,x:tuple2d)=p.(x.2,x.1) +proc reduce(p:proc,x:tuple3d)=p.(p.(x.3,x.2),x.1) +proc reduce(p:proc,x:tuple4d)=p.(p.(p.(x.4,x.3),x.2),x.1) +proc reduce(p:proc,x:tuple5d)=p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple6d)=p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1) + +proc map(p:proc,x:tuple1d)=[p.(x.1)] +proc map(p:proc,x:tuple2d)=[p.(x.1),p.(x.2)] +proc map(p:proc,x:tuple3d)=[p.(x.1),p.(x.2),p.(x.3)] +proc map(p:proc,x:tuple4d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4)] +proc map(p:proc,x:tuple5d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)] +proc map(p:proc,x:tuple6d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)] +proc map(p:proc,x:tuple7d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)] +proc map(p:proc,x:tuple,y:tuple)=compile_error("Number of dimensions does not match") +proc map(p:proc,x:tuple1d,y:tuple1d)=[p.(x.1,y.1)] +proc map(p:proc,x:tuple2d,y:tuple2d)=[p.(x.1,y.1),p.(x.2,y.2)] +proc map(p:proc,x:tuple3d,y:tuple3d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)] +proc map(p:proc,x:tuple4d,y:tuple4d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4)] +proc map(p:proc,x:tuple5d,y:tuple5d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5)] +proc map(p:proc,x:tuple6d,y:tuple6d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)] +proc map(p:proc,x:tuple7d,y:tuple7d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)] +proc map(p:proc,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(x.1,y.1,z.1)] +proc map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)] +proc map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)] +proc map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4)] +proc map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)] +proc map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)] +proc map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),p.(x.7,y.7,z.7)] + +proc map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(w.1,x.1,y.1,z.1)] +proc map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)] +proc map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)] +proc map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4)] +proc map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)] +proc map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)] +proc map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),p.(w.7,x.7,y.7,z.7)] + +proc map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]where u1,v1=p.(x.1,y.1) +proc map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2) +proc map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3) +proc map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4) +proc map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5) +proc map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6) +proc map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7) + +proc map_const(p:proc,x:tuple1d,y)=[p.(x.1,y)] +proc map_const(p:proc,x:tuple2d,y)=[p.(x.1,y),p.(x.2,y)] +proc map_const(p:proc,x:tuple3d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y)] +proc map_const(p:proc,x:tuple4d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y)] +proc map_const(p:proc,x:tuple5d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y)] +proc map_const(p:proc,x:tuple6d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y)] +proc map_const(p:proc,x:tuple7d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)] + +proc map_reduce(q:proc,p:proc,x:tuple1d)=q.(x.1) +proc map_reduce(q:proc,p:proc,x:tuple2d)=p.(q.(x.2),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d)=p.(p.(q.(x.3),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d)=p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d)=p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d)=p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)=q.(x.1,y.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.2,y.2),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(p.(q.(x.3,y.3),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=q.(x.1,y.1,z.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) + +proc apply(p:proc,x:tuple1d)=p.(x.1) +proc apply(p:proc,x:tuple2d)=p.(x.1,x.2) +proc apply(p:proc,x:tuple3d)=p.(x.1,x.2,x.3) +proc apply(p:proc,x:tuple4d)=p.(x.1,x.2,x.3,x.4) +proc apply(p:proc,x:tuple5d)=p.(x.1,x.2,x.3,x.4,x.5) +proc apply(p:proc,x:tuple6d)=p.(x.1,x.2,x.3,x.4,x.5,x.6) +proc apply(p:proc,x:tuple7d)=p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7) + +proc map_apply(q:proc,p:proc,x:tuple1d)=p.(q.(x.1)) +proc map_apply(q:proc,p:proc,x:tuple2d)=p.(q.(x.1),q.(x.2)) +proc map_apply(q:proc,p:proc,x:tuple3d)=p.(q.(x.1),q.(x.2),q.(x.3)) +proc map_apply(q:proc,p:proc,x:tuple4d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4)) +proc map_apply(q:proc,p:proc,x:tuple5d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5)) +proc map_apply(q:proc,p:proc,x:tuple6d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6)) +proc map_apply(q:proc,p:proc,x:tuple7d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6),q.(x.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type():compile_error("Number of dimensions does not match") +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)=p.(q.(x.1,y.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.1,y.1),q.(x.2,y.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=p.(q.(x.1,y.1,z.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7)) + +proc scan(p:proc,x:tuple1d)=x.1 +proc scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)] +proc scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)] where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +proc pre_scan(p:proc,x:tuple1d,x0)=x0 +proc pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1] +proc pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)] +proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +type empty_head is unique{empty_head} + +proc head(x:null)=empty_head +proc head(x:tuple)=x.1 + +proc tail(x:null)=null +proc tail(x:tuple1d)=null +proc tail(x:tuple2d)=[x.2] +proc tail(x:tuple3d)=[x.2,x.3] +proc tail(x:tuple4d)=[x.2,x.3,x.4] +proc tail(x:tuple5d)=[x.2,x.3,x.4,x.5] +proc tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6] +proc tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7] + +proc prepend(y,x:null)=[y] +proc prepend(y,x:tuple1d)=[y,x.1] +proc prepend(y,x:tuple2d)=[y,x.1,x.2] +proc prepend(y,x:tuple3d)=[y,x.1,x.2,x.3] +proc prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4] +proc prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5] +proc prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6] +proc prepend(y,x:tuple7d)=error_type() :compile_error("Cannot add dimension to 7d tuple") + +proc append(x:null,y)=[y] +proc append(x:tuple1d,y)=[x.1,y] +proc append(x:tuple2d,y)=[x.1,x.2,y] +proc append(x:tuple3d,y)=[x.1,x.2,x.3,y] +proc append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y] +proc append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y] +proc append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y] +proc append(y,x:tuple7d)=error_type() :compile_error( "Cannot add dimension to 7d tuple") + +proc elems(x:tuple1d)=x.1 +proc elems(x:tuple2d)=x.1,x.2 +proc elems(x:tuple3d)=x.1,x.2,x,3 +proc elems(x:tuple4d)=x.1,x.2,x.3,x.4 +proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 +proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 +proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 + +proc replace(x:tuple1d,y:literal(1),z)=[z] +proc replace(x:tuple2d,y:literal(1),z)=[z,x.2] +proc replace(x:tuple3d,y:literal(1),z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:literal(1),z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:literal(2),z)=[x.1,z] +proc replace(x:tuple3d,y:literal(2),z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:literal(2),z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:literal(3),z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:literal(3),z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:literal(4),z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:literal(7),z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or literal(1))=[x] +proc spread(x,y:tuple2d or literal(2))=[x,x] +proc spread(x,y:tuple3d or literal(3))=[x,x,x] +proc spread(x,y:tuple4d or literal(4))=[x,x,x,x] +proc spread(x,y:tuple5d or literal(5))=[x,x,x,x,x] +proc spread(x,y:tuple6d or literal(6))=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or literal(7))=[x,x,x,x,x,x,x] + +proc +(x:tuple(num),y:tuple(num))=map($+,x,y) + +proc -(x:tuple(num),y:tuple(num))=map($-,x,y) +proc *(x:tuple(num),y:tuple(num))=map($*,x,y) +proc /(x:tuple(num),y:tuple(num))=map($/,x,y) +proc **(x:tuple(num),y:tuple(num))=map($**,x,y) +proc mod(x:tuple(num),y:tuple(num))=map($mod,x,y) +proc +(x:tuple(num),y:num)=map_const($+,x,y) +proc -(x:tuple(num),y:num)=map_const($-,x,y) +proc *(x:tuple(num),y:num)=map_const($*,x,y) +proc /(x:tuple(num),y:num)=map_const($/,x,y) +proc **(x:tuple(num),y:num)=map_const($**,x,y) +proc mod(x:tuple(num),y:num)=map_const($mod,x,y) +proc max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y) +proc min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y) +proc max(x:tuple(real_num))=reduce($max,x) +proc min(x:tuple(real_num))=reduce($min,x) +proc sum(x:tuple(num))=reduce($+,x) +proc prod(x:tuple(num))=reduce($*,x) +proc sint(x:tuple(num))=map($sint,x) +proc int(x:tuple(num))=map($int,x) +proc sreal(x:tuple(num))=map($sreal,x) +proc real(x:tuple(num))=map($real,x) + +proc string(x:tuple1d)="[ "++x.1++" ]" +proc string(x:tuple2d)="[ "++x.1++", "++x.2++" ]" +proc string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]" +proc string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]" +proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]" +proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" +proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + +// ***************************************************** +// RANGES AND SEQUENCES +// ***************************************************** + +// Partial ranges and sequences for slicing +type underscore is unique{PM__underscore} +type _subscript is any_int,range(any_int),seq(any_int,any_int),underscore,range_below(any_int),range_above(any_int),seq_above(any_int,any_int), seq_below(any_int,any_int), seq_stride(any_int) +type subscript is _subscript or tuple(_subscript) +type extent(ndim:dimension_number) is tuple(range(int),ndim) +proc size(x:extent)=map_reduce($size,$*,x) + +proc complete(x:extent,y:subscript)=_complete(x,y) check "Subscript "++y++" is out of bounds "++x=>y in x +proc _complete(x:tuple1d,y:_subscript)=_complete(x.1,y) +proc _complete(x:range(int),y:any_int)=int(y) +proc _complete(x:range(int),y:range(any_int))=int(y) +proc _complete(x:range(int),y:seq(any_int,any_int))=int(y) +proc _complete(x:range(int),y:underscore)=x +proc _complete(x:range(int),y:range_below(any_int))=low(x)..int(y._t) +proc _complete(x:range(int),y:range_above(any_int))=int(y._t)..high(x) +proc _complete(x:range(int),y:seq_below(any_int))=low(x)..int(y._t) by int(y._st) +proc _complete(x:range(int),y:seq_above(any_int))=int(y._t)..high(x) by int(y._st) +proc _complete(x:range(int),y:seq_step(any_int))=x by int(y._st) +proc _complete(x,y)=map($_complete,x,y) check "Subscript has incorrect rank"=>rank(x)==rank(y) + +type range_below(x:range_base) is rec {_t:x} +type range_above(x:range_base) is rec {_t:x} +type seq_below(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_above(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_step(x:step_base) is rec {_st:step_base} +proc ..(x:underscore,y:range_base)=rec range_below{_t=x} +proc ..(x:range_base,y:underscore)=rec range_above{_t=x} +proc by(x:range_below,y:step_base)=rec seq_below{_t=x,_st=y} +proc by(x:range_above,y:step_base)=rec seq_above{_t=x,_st=y} +proc by(x:underscore,y:step_base)=rec seq_step{_st=y} +proc string(x:range_below)="_.."++x._t +proc string(x:range_above)=x._t++".._" +proc string(x:seq_below)="_.."++x._t++" by "++x._st +proc string(x:seq_above)=x._t++".._ by "++x._st +proc string(x:seq_step)="_ by "++x._st +proc low(x:range_below or seq_below or seq_step)=_ +proc high(x:range_above or seq_above or seq_step)=_ +proc step(x:range_above or range_below)=literal(1) +proc low(x:range_above or seq_above)=x._t +proc high(x:range_below or seq_below)=x._t +proc step(x:seq_above or seq_below or seq_step)=x._st + +// Not in operator +proc notin(x,y)=not(x in y) + +// not inc operator +proc notinc(x,y)=not(x inc y) + +// Treat null as empty sequence in some cases +proc in(x,y:null)=literal(false) +proc in(x:null,y:null)=literal(true) + +// Range base type (might later expand to interface) +type range_base is real_num +type step_base is real_num + +// Range types +type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} +proc ..(x:range_base,y:range_base)=rec range { +_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:range)=x._lo +proc high(x:range)=x._hi +proc step(x:range)=convert(1,x._lo) +proc width(x:range)=literal(1) +proc norm(x:range)=x +proc #'(x:range(int))=[0..x._n-1] +proc dims(x:range(int))=[x._n] +proc size(x:range(int))=x._n +proc +(x:range,y:range_base)=rec range { + _lo=x._lo+y,_hi=x._hi+y,_n=x._n +} +proc -(x:range,y:range_base)=rec range { + _lo=x._lo-y,_hi=x._hi-y,_n=x._n +} +proc _arb(x:range)=low(x) +proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi +proc convert(x:range,y:range_base)=rec range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n +} +proc sint(x:range)=rec range { + _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n +} +proc int(x:range)=rec range { + _lo=int(x._lo),_hi=int(x._hi),_n=x._n +} +proc sreal(x:range)=rec range { + _lo=sreal(x._lo),_hi=sreal(x._hi) +} +proc real(x:range)=rec range { + _lo=real(x._lo),_hi=real(x._hi),_n=x._n +} +proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi +proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) +proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st +proc element(x:range(any_int),y:null)=x +proc element(x:range(any_int),y:any_seq)=y+x._lo +proc #'(y:range(any_int),x:int)=int(x-y._lo) +proc #'(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #'(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #'(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #'(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #'(y:range(any_int),x:seq_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #'(y:range(any_int),x:seq_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #'(y:range(any_int),x:seq_step(int))=_intseq(0,size(y),int(x._st)) +proc #'(y:range(any_int),x:null)=0..size(y) +proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) +proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo +proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi +proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi +proc empty(x:range)=rec range { + _lo=x._hi,_hi=x._lo,_n=0 +} +proc string(x:range)=string(x._lo)++".."++(x._hi) + +// Sequence (strided range) types +type seq(t:range_base,s:step_base) is rec {_lo:t,_hi:t,_st:s,_n:int} +proc _seq(lo,hi,st)=rec seq { +_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) +proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) +proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y +proc _intseq(x:int,y:int,st:int)= rec seq { +_lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) +proc low(x:seq)=x._lo +proc high(x:seq)=x._hi +proc step(x:seq)=x._st +proc size(x:seq)=x._n +proc width(x:seq)=literal(1) +proc norm(x:seq)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)=literal(0) +proc #'(x:seq)=[0..x._n-1] +proc dims(x:seq)=[x._n] +proc +(x:seq,y:range_base)=rec seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n +} +proc -(x:seq,y:range_base)=rec seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n +} +proc _arb(x:seq)=x._lo +proc convert(x:seq,y:range_base)=rec seq { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n +} +proc sint(x:seq)=rec seq { + _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n +} +proc int(x:seq)=rec seq { + _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n +} +proc sreal(x:seq)=rec seq { + _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n +} +proc real(x:seq)=rec seq { + _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n +} +proc in(x:int,y:seq(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:seq(int),y:seq(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:seq(int),y:range(int))=x inc low(y)..high(y) by 1 +proc #'(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #'(y:seq,x:range)=y#x._lo..y#x._hi +proc #'(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #'(y:seq,x:range_below)=0..y#x._t +proc #'(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #'(y:seq,x:seq_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_step)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:null)=0..size(y)-1 +proc string(x:seq)=x._lo++".."++x._hi++" by "++x._st +proc element(x:seq,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:seq,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:seq,y:seq(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:seq,y:null)=x +proc overlap(x:seq(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:seq(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:seq(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:seq(any_int))=intersect(y,x) +PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" +proc intersect(x:seq(any_int),y:seq(any_int))=rec seq { +_lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc overlap(x:seq(any_int),y:seq(any_int))=rec seq { +_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc empty(x:seq(any_int))=rec seq { + _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 +} + +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=rec block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #'(x:block_seq)=[0..x._n-1] +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=rec block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=rec block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + let align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + let z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + let z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + let z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) + +/* +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:any_seq){ + var a=array(0,#x) + forall i in a,j in x:i=j + return rec map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=rec map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + /* + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +*/ +} +proc map_seq(x:map_seq)=x +proc #'(x:map_seq)=#'(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=rec map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=rec map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=rec map_seq { + array=a[ns] + } + w=rec map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=rec map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #'(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return rec map_seq { + array=a + } +} +*/ +proc map_seq(x)=x +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) + + +type any_seq is range(int),seq(int,int),block_seq // , map_seq + +// Grids (tuples of sequences) +type _gdim is any_seq or int +type grid1d(t1:_gdim) is [t1] except [int] +type grid2d(t1:_gdim,t2:_gdim) is [t1,t2] except [int,int] +type grid3d(t1:_gdim,t2:_gdim,t3:_gdim) is [t1,t2,t3] except [int,int,int] +type grid4d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim) is [t1,t2,t3,t4] except [int,int,int,int] +type grid5d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim) is [t1,t2,t3,t4,t5] except [int,int,int,int,int] +type grid6d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim) is [t1,t2,t3,t4,t5,t6] except [int,int,int,int,int,int] +type grid7d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim,t7:_gdim) is [t1,t2,t3,t4,t5,t6,t7] except [int,int,int,int,int,int,int] +type grid(ndim:dimension_number) is tuple(_gdim,ndim) except tuple(int,ndim) + +PM__intrinsic _shp(x:int)->(PM__tinyint) : "miss_arg" +proc _shp(x)=0..size(x)-1 +proc _sliceit(...)=tuple(...) +proc #'(x:grid)=map_apply($_shp,$_sliceit,x) +PM__intrinsic _size(x:int)->(PM__tinyint) : "miss_arg" +proc _size(x)=size(x) +proc extent(x:grid)=map_apply($_shp,$_sliceit,x) +proc dims(x:grid)=map_apply($_size,$_sliceit,x) +proc low(x:grid)=map($low,x) +proc high(x:grid)=map($high,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($-,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:tuple(any_seq),y)=map($element,x,y) +proc element(x:grid,y)=_gel(head(x),tail(x),head(y),tail(y)) +proc _gel(x:_gdim,xx,y,yy)=prepend(element(x,y),_gel(head(xx),tail(xx),head(yy),tail(yy))) +proc _gel(x:int,xx,y,yy)=prepend(x,_gel(head(xx),tail(xx),y,yy)) +proc _gel(x:empty_head,xx,y:empty_head,yy)=null +proc _gel(x:empty_head,xx,y,yy)=error_type():compile_error("Rank mismatch") + + + +// ************************************** +// ARRAYS +// ************************************** + +/* +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) +type farray(e,d:shape) is e^let d,e^invar d,e^fix d,array_template(e,d,fix(false)) +type farray(e,d:mshape) is ..., + array_slice(e^let any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix any) + +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif + +*/ + +PM__intrinsic<> _array(x:any,y:any,z:any)->(=x) : "array" +PM__intrinsic<> _varray(x:any,y:any,z:any)->(=x) : "var_array" + + +PM__intrinsic _array_mshape(x:any^any)->(=x) : "get_dom" +PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +proc array(x,d:extent)=_array(x,_mshape(d),size(d)) +proc #'(x:any^any)=_array_mshape(x)._extent +proc element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) + + +/* +PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(=x) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #'(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(=x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(=x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + +proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) +PM__intrinsic _make_subref(a:any^mshape,i:int)->(=a) : "make_rf" +PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" + +*/ + +type _mshape(ndim:dimension_number,contig:literal(bool)) is rec {_extent:extent(ndim),_m:tuple(int,ndim),_n:int,_o:int,_c:contig} +proc _mshape(g:extent(1))=rec _mshape{_extent=g,_m=[1],_n=size(g.1),_o=o,_c=true} where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(2))=rec _mshape{_extent=g,_m=[1,s1],_n=s1*size(g.2),_o=o,_c=true} where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(3))=rec _mshape{_extent=g,_m=[1,s1,s2],_n=s2*size(g.3),_o=o,_c=true} where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(4))=rec _mshape{_extent=g,_m=[1,s1,s3,s3],_n=s3*size(g.4),_o=o,_c=true} where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(5))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4],_n=s4*size(g.5),_o=o,_c=true} where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(6))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5],_n=s5*size(g.6),_o=o,_c=true} where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(7))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5,s6],_n=s6*size(g.7),_o=o,_c=true} where s6=s5*size(g.6) where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) + + +// Linear index of mshape (zero base,unit stride) +proc _point2index(g:_mshape,p:tuple(any_int))=_point2index(g,int(p)) +proc _point2index(g:_mshape(1,literal(true)),p:tuple(int,1))=g._o+g._m.1*p.1 +proc _point2index(g:_mshape(2,literal(true)),p:tuple(int,2))=g._o+g._m.1*p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,literal(true)),p:tuple(int,3))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,literal(true)),p:tuple(int,4))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,literal(true)),p:tuple(int,5))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,literal(true)),p:tuple(int,6))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,literal(true)),p:tuple(int,7))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape(1,literal(false)),p:tuple(int,1))=g._o+p.1 +proc _point2index(g:_mshape(2,literal(false)),p:tuple(int,2))=g._o+p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,literal(false)),p:tuple(int,3))=g._o+p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,literal(false)),p:tuple(int,4))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,literal(false)),p:tuple(int,5))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,literal(false)),p:tuple(int,6))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,literal(false)),p:tuple(int,7))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape,p:tuple(int))=0: compile_error("Rank mismatch in index") + +// Linear index of tuple of ranges or ints (zero base) +proc _indx(g:range(int),s)=int(s)-low(g) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _point2index(g:tuple(int,1) or extent(1),s:any_int)=int(_indx(g.1,s)) +proc _point2index(g:tuple(int,1) or extent(1),s:tuple(any_int,1))=int(_indx(g.1,s.1)) +proc _point2index(g:tuple(int,2) or extent(2),s:tuple(any_int,2))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2)) +proc _point2index(g:tuple(int,3) or extent(3),s:tuple(any_int,3))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3))) +proc _point2index(g:tuple(int,4) or extent(4),s:tuple(any_int,4))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4)))) +proc _point2index(g:tuple(int,5) or extent(5),s:tuple(any_int,5))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5))))) +proc _point2index(g:tuple(int,6) or extent(6),s:tuple(any_int,6))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6)))))) +proc _point2index(g:tuple(int,7) or extent(7),s:tuple(any_int,7))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7)))))))) + +proc _index2point(i:int,s:range(int))=[i+s._lo] +proc _index2point(i:int,s:int)=[i] +proc _index2point(i:int,s:tuple(int,1))=[i] +proc _index2point(i:int,s:tuple(int,2))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,3))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,4))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,5))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,6))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,7))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) + +/* +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} + + +// ***************************************** +// ARRAY TEMPLATES +// ***************************************** +// Array templates +type array_template(a,d:mshape or dshape,v:fix(bool)) is rec {_a:a,_d:d,_s:int,_v:v} +proc array(a:any,s:dshape)=rec array_template { + _a=a,_d=s,_s=s._size,_v=fix(false) +} +proc array(a:any,s:mshape(tuple(range(int))))=rec array_template { + _a=a,_d=s,_s=size(s),_v=fix(false) +} +proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) +proc varray(a:any,s:mshape or dshape)=rec array_template { + _a=a,_d=s,_s=size(s),_v=fix(true) +} +proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) +proc _zero(x)=0 +proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) +// Treat a template as if it were an array +proc _arb(a:array_template)=a._a +proc #(a:array_template(,mshape,))=a._d +proc dims(a:array_template(,mshape,))=dims(a._d) +proc size(a:array_template)=a._s +proc redim(a:array_template,d:mshape)= rec array_template { +_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s +proc element(a:array_template,...:subs)=a._a +// Array creation from template + +proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) +proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) +proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) + +*/ + +// *************************************************** +// LOOPS AND PARALLEL STATEMENTS +// *************************************************** + +proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) <> { + PM__for shape { + here_in_tile=PM__generate(shape,shape) + PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { + var inouts=PM__import(PM__inouts) + var inout_a=PM__get_elem(PM__inout_a,here_in_tile) + PM__block_proc.'(&inouts, + PM__import(PM__ins), + &inout_a, + PM__get_elem(PM__in_a,here_in_tile), + PM__get_elem(PM__star_a,here_in_tile) <>) + PM__export(&PM__inouts,inouts) + PM__set_elem(&PM__inout_a,inout_a,here_in_tile) + } + } +} + +proc PM__par_stmt'(num) yield() <> { yield() } +proc PM__check_task'(num)=true + +proc PM__chan_stmt'() yield() { yield() } +proc PM__over_stmt'(x) yield() { yield() } + +proc #'(x)=x + +proc PM__check_iter(x){} +proc PM__check_iter_amp(x){} +proc PM__check_iter_star(x){} +proc PM__check_iter(x,y){} +proc PM__check_iter_amp(x,y){} +proc PM__check_iter_star(x,y){} + +proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):h) +proc PM__get_elem(x,h)=h +proc PM__set_elem(&x,y,h) {} +proc PM__export(&x,y) {} + +proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(element_at_index(x,i))) +PM__intrinsic PM__import(x:any)->(=x) : "import_val" + +proc PM__generate(x,n)=old_dumpit(_elts(x,1,n)) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=old_dumpit(_iota(siz,0,x,1,tot)) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) + +// ************************************************** +// SUPPORT FOR OTHER LANGUAGE FEATURES +// ************************************************** + +// Keyword arguments +proc PM__getkey(x:any,y:any)=convert(x,y) +proc PM__getkey(x:null,y:any)=y + +// Switch statement +proc PM__checkcase(x:literal,y:literal)=match_switch_case(x,y) +proc PM__checkcase(x,y)=match_switch_case(x,y) +proc match_switch_case(x:literal,y:literal)=x==y +proc match_switch_case(x:fix(any),y:fix(any))=x==y +proc match_switch_case(x,y)=x==y +proc match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi +proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:literal(int),y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x +type _crange is rec{_lo,_hi} +proc PM__caserange(x,y)=x..y +proc PM__caserange(x:fix(int),y:fix(int))=rec _crange{ + _lo=x,_hi=y +} + +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:fix(true),y,z)=y +proc PM__if(x:fix(false),y,z)=z +proc PM__if(x:fix(true),y:literal,z)=y +proc PM__if(x:fix(false),y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) + +/* +// Assignment +proc PM__assign_or_init(a,b)<>=a { + PM__assign_var(&^(a),b) +} +*/ + + +/* +type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... + +proc PM__assign(&a:any,b:any,c:assignment_operator) { + PM__assign(&a,c.(a,b)) +} +*/ + +proc PM__assign(&a:any,b:any,c:proc) { + compile_error("Not a recognised assignment operator") +} + +proc check_assign_types(x,y){ + test "Type mismatch in assignment"=>same_type(x,y) +} +proc _assign(&a,b) { + _assign_element(&a,b) +} + +/* +proc _assign(&a:contains(farray),b) { + _assign_structure(&a,b) +} +*/ +/* +proc _assign_structure(&a,b)<>{ + _assign_element(&a,b) +} +proc _assign_structure(&a:farray,b){ + _array_assign(&a,b,fix(true)) +} +*/ +PM__intrinsic _assign_element(&any,any): "assign" + + +// Other variable operations + +proc PM__assign_or_init(&a:PM__assign_or_init,b)=PM__dup(b as a) + +proc PM__assign_or_init(&a,b)=a:PM__assign(&a,b) + +proc PM__init_const(&a:PM__assign_or_init,b)=PM__dup(b as a) + +proc PM__init_const(&a,b)=a: compile_error( "Cannot initialise a constant twice") + +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} + +proc PM__dup(x)=x + +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a +} + +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv +PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv +PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" +PM__intrinsic PM__make_const(x:any)->(=x) : "clone_var" +proc PM__init_var(x:any,y:any)=PM__make_var(x,y) +proc PM__init_const(x:any,y:any)=PM__make_const(x,y) +proc PM__init_var'(x:any,y:any)=PM__make_var'(x,y) +proc PM__init_const'(x:any,y:any)=PM__make_const'(x,y) +proc PM__make_var(x,y)=PM__make_var(x as y) +proc PM__make_const(x,y)=PM__make_const(x as y) +PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" +/* +PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" +PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" +PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" +PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" +PM__intrinsic PM__dup(x:literal(int))->(int) : "clone" +PM__intrinsic PM__dup(x:literal(real))->(real) : "clone" +PM__intrinsic PM__dup(x:literal(string))->(string) : "clone" +PM__intrinsic PM__dup(x:literal(bool))->(bool) : "clone" +*/ +PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" +PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" + +/* +proc ==(x:any,y:any) { + test "Cannot apply ""=="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return not ok +} +proc _eq(x:any,y:any,&ok) <> { + ok=ok and x==y +} +*/ + +proc PM__valref(x)=x +proc PM__check_alias(...){} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) + +PM__intrinsic<> .element_at_index(&x:any,y:fix(int))->(|x):"elem" +PM__intrinsic<> element_at_index(x:any,y:fix(int))->(|x):"elem" + +proc elements(x)=_elements(x,1) +proc _elements(x,i:literal(int)) { + let e... + if fix(i==num_elements(x)) { + let ...e=_cons(PM__element_at(x,i),_list_end) + } else { + let ...e=_cons(PM__element_at(x,i),_elements(x,i+1)) + } + return e +} + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnt(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=PM__cast(x,typeof(t)) +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic error_type()->(=1) : "error_type" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump(x)<>:_dump("Value:",x) +proc PM__dump(y,x)<>:if y:_dump("Value:",x) +/* +proc PM__dump%(x)<>{ + print("$"++here) + _dump(string(here),x) +} +proc PM__dump%(y:bool,x)<>{ + if y:_dump(string(here),x) +} +proc PM__dump%(y,x){ + test "Selection expression in ""$$dump"" not ""bool""" => fix(false) + $$infer_type(y) +} +*/ +PM__intrinsic<> old_dump(any): "dump" +proc old_dumpit(a) { + old_dump(a) + return a +} + +PM__intrinsic<> old_dump_id(any): "dump_id" + +proc PM__filesys()=1234 + +proc PM__check_alias(a,b) {} +proc PM__lhs_and_val(a)=a +proc PM__rhs_and_val(a)=a +proc PM__copy_in(a)=a +proc PM__copy_out(&a,b):a=b + +proc PM__for_in(a)=a +proc PM__for_var(a)=a + +proc PM__import_param'(x)=x +proc PM__export_param'(x)=x +proc PM__import_param'(&x,y){} + +proc PM__make_over'(a)=a + +PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_concat" +PM__intrinsic<> PM__list_splice(x:PM__list,y:PM__list,i:literal(int),j:literal(int))->(=x):"list_splice" + +proc compile_error(mess:literal(string)): test mess=>false diff --git a/src/ast.f90 b/src/ast.f90 index caedeba..4a01fae 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -154,6 +154,7 @@ module pm_ast integer,parameter:: call_is_unlabelled = 2**17 integer,parameter:: call_takes_uninit = 2**18 integer,parameter:: call_converts_uninit = 2**19 + integer,parameter:: call_keep_literals = 2**20 contains diff --git a/src/codegen.f90 b/src/codegen.f90 index eb9b753..94fad17 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -694,6 +694,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,sym_pm_foreach,3,0) call pop_lex_scope(coder) + case(sym_repl_line) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + call make_sys_call(coder,cblock,node,sym_print,1,0) case default if(sym>0.and.sym=2,.false.) + at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals)==0,ipass>=2,.false.) if(at2>0) at=at2 endif if(pm_type_includes(coder%context,& @@ -2860,7 +2864,7 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) new_at=at return else - at2=pm_type_convert(coder%context,pt,at,.true.,ipass>=2,.false.) + at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals)==0,ipass>=2,.false.) if(at2>0) then new_at=at2 return @@ -3250,7 +3254,8 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) endif if(.not.ok) then call inf_error(coder,node,& - 'Value cannot be cast to the given type') + 'Value of type "'//trim(pm_type_as_string(coder%context,tno2))//& + '" cannot be cast to type "'//trim(pm_type_as_string(coder%context,tno1))//"'") call inf_trace(coder) endif contains diff --git a/src/lib.f90 b/src/lib.f90 index 21c3c6d..1a92393 100755 --- a/src/lib.f90 +++ b/src/lib.f90 @@ -103,7 +103,7 @@ function pm_get_source_line(context,modl_name,lineno,buffer) result(iserr) !if(.not.pm_main_process) call pm_panic('pm_get_source_line - not main process') iserr=.true. if(modl_name==sym_pm_system) then - call pm_module_filename('lib.sys.pm',buffer) + call pm_module_filename('lib.sys.pm',buffer,pm_opts%lib_path_set,pm_opts%lib_path) open(unit=3,file=buffer,status='OLD',err=20) do i=1,lineno read(3,'(A1024)',err=20,end=20) buffer @@ -111,7 +111,7 @@ function pm_get_source_line(context,modl_name,lineno,buffer) result(iserr) close(3) else call pm_module_filename(trim(pm_name_as_string(context,& - modl_name)),buffer) + modl_name)),buffer,pm_opts%lib_path_set,pm_opts%lib_path) open(unit=3,file=buffer,status='OLD',err=20) do i=1,lineno read(3,'(A1024)',err=20,end=20) buffer diff --git a/src/linker.f90 b/src/linker.f90 index 6245f28..ad8a7d6 100755 --- a/src/linker.f90 +++ b/src/linker.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -33,7 +33,8 @@ module pm_linker implicit none integer,parameter:: max_link_errors=20 - + logical,parameter:: debug_linker=.false. + contains !================================================= @@ -41,53 +42,60 @@ module pm_linker ! modules !================================================= - ! Process all include statements + ! Process all 'use' statements in all modules subroutine link_includes(context,nerror,modl_dict) type(pm_context),pointer:: context integer,intent(inout):: nerror - type(pm_ptr):: modl_dict - type(pm_ptr),target:: modls,modl,dict - type(pm_ptr),target:: incls,node,imodl - type(pm_ptr)::p - type(pm_reg),pointer:: reg - integer:: i,j - character(len=100):: str - reg=>pm_register(context,'link includes',modls,modl,& - dict,incls,node,imodl) + type(pm_ptr),intent(in):: modl_dict + type(pm_ptr):: modls,modl + integer:: j modls=pm_dict_vals(context,modl_dict) ! Loop through all loaded modules do j=0,pm_dict_size(context,modl_dict)-1 modl=modls%data%ptr(modls%offset+j) - dict=modl%data%ptr(modl%offset+modl_include) - incls=pm_dict_vals(context,dict) - ! Loop through include definitions for given module - do i=0,pm_dict_size(context,dict)-1 - node=incls%data%ptr(incls%offset+i) - if(pm_debug_level>5) then - call pm_name_string(context,& - int(node%data%ptr(node%offset+node_args)%offset),str) - write(*,*) 'including',trim(str) - p=pm_dict_key(context,dict,int(i+1,pm_ln)) - write(*,*) '..',trim(pm_name_as_string(context,int(p%offset))) - endif - imodl=node%data%ptr(node%offset+node_args+1) - if(modl==imodl) then - call link_error(context,nerror,node,'Module cannot include itself') - endif - if(node_sym(node)==sym_use) then - call link_include(context,nerror,node,modl,imodl) - else - call link_include_mod(context,nerror,node,modl,imodl) - endif - if(pm_debug_level>5) then - write(*,*) '... included ',trim(str) - endif - enddo + call link_includes_for_module(context,nerror,modl) enddo - call pm_delete_register(context,reg) end subroutine link_includes - ! Process a single unmodified include statement + ! Process all 'use' statements in a single module + subroutine link_includes_for_module(context,nerror,modl) + type(pm_context),pointer:: context + integer,intent(inout):: nerror + type(pm_ptr),intent(in):: modl + type(pm_ptr):: modls,dict + type(pm_ptr)::incls,node,imodl + type(pm_ptr)::p + type(pm_reg),pointer:: reg + integer:: i + character(len=100):: str + dict=modl%data%ptr(modl%offset+modl_include) + incls=pm_dict_vals(context,dict) + ! Loop through include definitions for given module + do i=0,pm_dict_size(context,dict)-1 + node=incls%data%ptr(incls%offset+i) + if(debug_linker) then + call pm_name_string(context,& + int(node%data%ptr(node%offset+node_args)%offset),str) + write(*,*) 'including',trim(str) + p=pm_dict_key(context,dict,int(i+1,pm_ln)) + write(*,*) '..',trim(pm_name_as_string(context,int(p%offset))) + endif + imodl=node%data%ptr(node%offset+node_args+1) + if(modl==imodl) then + call link_error(context,nerror,node,'Module cannot include itself') + endif + if(node_sym(node)==sym_use) then + call link_include(context,nerror,node,modl,imodl) + else + call link_include_mod(context,nerror,node,modl,imodl) + endif + if(debug_linker) then + write(*,*) '... included ',trim(str) + endif + enddo + end subroutine link_includes_for_module + + ! Process a single unmodified 'use' statement subroutine link_include(context,nerror,node,modl,imodl) type(pm_context),pointer:: context integer,intent(inout):: nerror @@ -106,7 +114,7 @@ subroutine link_include(context,nerror,node,modl,imodl) enddo end subroutine link_include - ! Process a modified include statement + ! Process a modified 'use' statement subroutine link_include_mod(context,nerror,node,modl,imodl) type(pm_context),pointer:: context integer,intent(inout):: nerror @@ -142,7 +150,7 @@ subroutine link_include_elem(context,nerror,node,kind,modl,elem,imodl,val) type(pm_ptr),intent(in):: node,modl,elem,imodl,val type(pm_ptr),target:: dict,lcl_dict,idict,old,v1,v2 logical:: changed - if(pm_debug_level>2) then + if(debug_linker) then write(*,*) 'Include elem: ',trim(pm_name_as_string(context,int(elem%offset))),& ' to ',trim(pm_name_as_string(context,get_modl_name(modl))),& ' from ',trim(pm_name_as_string(context,get_modl_name(modl))) diff --git a/src/main.f90 b/src/main.f90 index bf2557a..ba2a984 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -67,7 +67,13 @@ program pm ! Command line call pm_get_command_line(context,module_name) - + + ! Run REPL if -i option is present + if(pm_opts%is_repl) then + call repl(context) + stop + endif + ! Compilation call run_parser(module_name,root_module,module_dict,visibility) call run_linker(root_module,module_dict) @@ -126,7 +132,7 @@ subroutine run_parser(mname,root,dict,visibility) call dcl_module(parser,'PM__system') parser%sysmodl=parser%modl - call pm_module_filename('lib.sys.pm',str2) + call pm_module_filename('lib.sys.pm',str2,pm_opts%lib_path_set,pm_opts%lib_path) call pm_open_file(pm_comp_file_unit,str2,ok) if(.not.ok) then if(pm_main_process) then @@ -154,7 +160,7 @@ subroutine run_parser(mname,root,dict,visibility) endif ! Parse other modules - call pm_module_filename(mname,str2) + call pm_module_filename(mname,str2,pm_opts%lib_path_set,pm_opts%lib_path) if(.not.pm_file_exists(str2)) then if(pm_main_process) then write(*,*) 'Cannot open source file '//trim(str2)//& @@ -175,7 +181,7 @@ subroutine run_parser(mname,root,dict,visibility) str=' ' module_name=get_modl_name(parser%modl) call pm_name_string(context,module_name,str) - call pm_module_filename(str,str2) + call pm_module_filename(str,str2,pm_opts%lib_path_set,pm_opts%lib_path) call pm_open_file(pm_comp_file_unit,str2,ok) if(.not.ok) then if(pm_main_process) then @@ -383,19 +389,72 @@ subroutine run_wcode_stage(prog_code,proc_cache,code_cache,poly_cache,typeset) endif end subroutine run_wcode_stage -!!$ subroutine repl -!!$ type(parse_state),target:: parser -!!$ type(code_state):: coder -!!$ type(wcoder),target:: wcd -!!$ -!!$ prog=root%data%ptr(root%offset+modl_stmts) -!!$ if(pm_fast_isnull(prog)) call pm_stop('No program defined to run') -!!$ call trav_prog(coder,prog) -!!$ call prc_prog(coder) -!!$ call init_wcoder(context,wcd,proc_cache,poly_cache) -!!$ call wcode_prog(wcd,prog_code) -!!$ call wcode_procs(wcd) -!!$ -!!$ end subroutine repl + subroutine repl(context) + type(pm_context),pointer:: context + type(parse_state),target:: parser + type(code_state):: coder + type(wcoder),target:: wcd + type(pm_ptr):: root,prog,dict + integer:: name,err + character(len=2000):: line,str2 + logical:: first + call init_parser(parser,context) + call dcl_module(parser,'PM__system') + parser%sysmodl=parser%modl + call pm_module_filename('lib.sys.pm',str2,pm_opts%lib_path_set,pm_opts%lib_path) + call pm_open_file(pm_comp_file_unit,str2,ok) + if(.not.ok) then + if(pm_main_process) then + write(*,*) 'Cannot open system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif + !write(*,*) 'Parsing',trim(str) + call parse_file_on_unit(parser,pm_comp_file_unit,.false.) + close(pm_comp_file_unit) + if(parser%error_count>0) then + if(pm_main_process) then + write(*,*) 'Cannot parse system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif + name=pm_name_entry(context,'PM__REPL') + call new_modl(parser,name) + root=parser%modls + parser%modl=parser%modls + first=.true. + do + write(*,'(a)',advance='NO') 'PM> ' + read(*,*) line + if(line=='exit') return + call parse_expr_from_string(parser,line,first) + first=.false. + dict=parser%modl_dict + visibility=parser%visibility + if(parser%error_count==0) then + err=0 + call link_includes(context,err,dict) + if(err==0) then + prog=root%data%ptr(root%offset+modl_stmts) + if(pm_fast_isnull(prog)) call pm_stop('No program defined to run') + !call dump_parse_tree(context,6,prog,2) + call init_coder(context,coder,visibility) + call trav_prog(coder,prog) + call inf_prog(coder) + if(coder%num_errors==0) then + prog_code=coder%vstack(1) + proc_cache=coder%proc_cache + call init_wcoder(context,wcd,proc_cache,pm_null_obj) + call wcode_prog(wcd,prog_code) + code_cache=wcd%code_cache + call wcode_procs(wcd) + if(wcd%num_errors==0) then + call pm_run_prog(context,pm_dict_vals(context,code_cache)) + endif + endif + endif + endif + enddo + end subroutine repl end program pm diff --git a/src/opts.f90 b/src/opts.f90 index afd4924..644178e 100755 --- a/src/opts.f90 +++ b/src/opts.f90 @@ -46,6 +46,8 @@ module pm_options logical:: show_all_ref logical:: print_immediate logical:: show_hidden + logical:: lib_path_set + character(len=pm_max_filename_size):: lib_path logical:: out_sysmod logical:: out_typelist @@ -67,6 +69,8 @@ module pm_options logical:: ftn_name_types logical:: ftn_name_elems + logical:: is_repl + character(len=25):: error character(len=7):: error_start logical:: colour @@ -92,6 +96,7 @@ subroutine init_opts(context) pm_opts%show_all_ref=.false. pm_opts%print_immediate=.false. pm_opts%show_hidden=.false. + pm_opts%lib_path_set=.false. pm_opts%out_sysmod=.false. pm_opts%out_typelist=.false. @@ -127,6 +132,14 @@ subroutine init_opts(context) pm_opts%error='Error: ' endif pm_opts%colour=colour + + call pm_get_env_var(pm_env_var,pm_opts%lib_path,pm_opts%lib_path_set) + if(.not.pm_opts%lib_path_set) then + pm_opts%lib_path_set=pm_default_lib_path_set + pm_opts%lib_path=pm_default_lib_path + endif + + pm_opts%is_repl=.false. end subroutine init_opts subroutine print_usage @@ -153,6 +166,9 @@ subroutine help write(*,*) ' Only the main (program) module must be named - other modules are' write(*,*) ' included automatically.' write(*,*) + write(*,*) ' CONFIGURATION OPTIONS' + write(*,*) ' -L Look for library files in rather than lib' + write(*,*) write(*,*) ' LANGUAGE OPTIONS' write(*,*) ' -fno-inline Do not inline any procedures.' write(*,*) ' -fno-check Do not run "check" or "test" statements.' @@ -231,7 +247,7 @@ end subroutine help subroutine pm_get_command_line(context,mname) type(pm_context),pointer:: context character(len=*),intent(out):: mname - character(len=pm_max_filename_size):: arg + character(len=pm_max_filename_size+5):: arg integer:: i,n call init_opts(context) n=pm_get_cl_count() @@ -243,6 +259,9 @@ subroutine pm_get_command_line(context,mname) write(*,*) 'Not a command line option: ',trim(arg) call usage() endif + elseif(arg(1:2)=='-L') then + pm_opts%lib_path_set=.true. + pm_opts%lib_path=arg(3:) elseif(arg=='-N') then pm_opts%error='Error:' pm_opts%colour=.false. @@ -397,6 +416,8 @@ subroutine pm_get_command_line(context,mname) call pm_get_cl_arg(i,mname) if(mname=='--help') then call help + elseif(mname=='-i') then + pm_opts%is_repl=.true. elseif(mname(1:1)=='-') then call usage() endif diff --git a/src/parser.f90 b/src/parser.f90 index 084366f..24d7b48 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -243,6 +243,26 @@ subroutine dcl_type(parser,def,line) endif end subroutine dcl_type + subroutine parse_expr_from_string(parser,line,use_sysmod) + type(parse_state),intent(inout):: parser + character(len=*),intent(in):: line + logical,intent(in):: use_sysmod + if(use_sysmod) then + call push_sym_val(parser,sym_pm_system) + call push_val(parser,parser%sysmodl) + call push_null_val(parser) + call make_node(parser,sym_use,3) + call new_import(parser,sym_pm_system,pop_val(parser)) + endif + call parse_from_string(parser,line) + call scan(parser) + call xexpr(parser) + call make_node(parser,sym_repl_line,1) + call make_node(parser,sym_list,1) + parser%modl%data%ptr(parser%modl%offset& + +modl_stmts)=pop_val(parser) + end subroutine parse_expr_from_string + !====================================================== ! Start parsing PM code from a string !====================================================== @@ -5970,7 +5990,7 @@ subroutine decl(parser,is_root_module) else if(parser%sym/=sym_eof) then call parse_error(parser,& - 'Library module cannot contain non-"debug" statement') + 'A library module cannot contain executable statements apart from "test"') end if call push_null_val(parser) end if @@ -6476,10 +6496,10 @@ subroutine new_modl(parser,name) modl=pm_dict_lookup(parser%context,parser%modl_dict,& nameval) if(pm_fast_isnull(modl)) then - if(pm_main_process.and.name/=sym_pm_system) then + if(pm_main_process.and.name/=sym_pm_system.and..false.) then call pm_name_string(parser%context,& int(nameval%offset),str) - call pm_module_filename(str,str2) + call pm_module_filename(str,str2,pm_opts%lib_path_set,pm_opts%lib_path) inquire(file=trim(str2),exist=ok) if(.not.ok) then call parse_error(parser,'module does not correspond to a source file, need: '//& diff --git a/src/symbol.f90 b/src/symbol.f90 index 1e24720..72acb28 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -341,9 +341,10 @@ module pm_symbol integer,parameter:: sym_dot_call = node0 + 50 integer,parameter:: sym_key = node0 + 51 integer,parameter:: sym_reference = node0 + 52 + integer,parameter:: sym_repl_line = node0 + 53 ! Misc. other symbols that need to be referenced by the compiler - integer,parameter:: hook = node0 + 53 + integer,parameter:: hook = node0 + 54 integer,parameter:: sym_pval_as = hook integer,parameter:: sym_pm_system = hook+1 integer,parameter:: sym_get_element = hook+2 @@ -409,7 +410,8 @@ module pm_symbol integer,parameter:: sym_check_task = hook + 62 integer,parameter:: sym_init_var = hook + 63 integer,parameter:: sym_init_const = hook + 64 - integer,parameter:: hook1 = hook + 64 + integer,parameter:: sym_print = hook + 65 + integer,parameter:: hook1 = hook + 65 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -816,6 +818,7 @@ module pm_symbol data sym_names(sym_dot_call) /''/ data sym_names(sym_key) /''/ data sym_names(sym_reference) /''/ + data sym_names(sym_repl_line) /''/ ! Misc. symbols referenced by compiler @@ -886,6 +889,7 @@ module pm_symbol data sym_names(sym_check_task) /'PM__check_task'/ data sym_names(sym_init_var) /'PM__init_var'/ data sym_names(sym_init_const) /'PM__init_const'/ + data sym_names(sym_print) /'print'/ data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ diff --git a/src/types.f90 b/src/types.f90 index be26f2a..f67f0b8 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -1437,7 +1437,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_any) do i=1,pm_tv_numargs(u) if(.not.pm_test_type_includes(context,p,pm_tv_arg(u,i),& - ior(mode,pm_type_incl_nomatch),params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.false. return endif @@ -1508,6 +1508,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& else ok=.true. endif + return case(pm_type_is_bottom) ok=.true. return @@ -1688,23 +1689,41 @@ recursive function pm_test_type_includes(context,supertype,subtype,& mode,params,base,user,ubase) endif case(pm_type_is_any) + ok=.false. do i=1,pm_tv_numargs(t) if(pm_test_type_includes(context,pm_tv_arg(t,i),q,& - ior(mode,pm_type_incl_nomatch),params,base,user,ubase)) then + mode,params,base,user,ubase)) then ok=.true. - return + if(iand(mode,pm_type_incl_extract+pm_type_incl_nomatch)/=pm_type_incl_extract) then + return + endif endif enddo - ok=.false. case(pm_type_is_all) do i=1,pm_tv_numargs(t) if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),q,& - mode,params,base,user,ubase)) then + ior(mode,pm_type_incl_nomatch),params,base,user,ubase)) then ok=.false. return endif enddo + ! Just when matching - need to run all and match + if(iand(mode,pm_type_incl_extract+pm_type_incl_nomatch)==pm_type_incl_extract) then + do i=1,pm_tv_numargs(t) + ok=pm_test_type_includes(context,pm_tv_arg(t,i),q,& + mode,params,base,user,ubase) + enddo + endif ok=.true. + case(pm_type_is_except) + ok=pm_test_type_includes(context,pm_tv_arg(t,2),q,& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) + if(.not.ok) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + mode,params,base,user,ubase) + else + ok=.false. + endif case(pm_type_is_single_name) ok=.false. case(pm_type_is_proc) @@ -1777,13 +1796,6 @@ recursive function pm_test_type_includes(context,supertype,subtype,& else ok=.false. endif - case(pm_type_is_except) - ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& - mode,params,base,user,ubase) - if(ok) then - ok=.not.pm_test_type_includes(context,pm_tv_arg(t,2),q,& - mode,params,base,user,ubase) - endif case(pm_type_is_params) nt=pm_tv_name(t) if(base+nt>size(params)) then @@ -2257,7 +2269,7 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c integer:: tk,ptyp,atyp,pmode,amode type(pm_ptr):: tv !!$ write(*,*) 'Convert',trim(pm_type_as_string(context,partyp)),& -!!$ '<-',trim(pm_type_as_string(context,argtyp)),doliteral,doproc +!!$ '::',trim(pm_type_as_string(context,argtyp)),doliteral,doproc ctyp=-1 if(partyp<0.or.argtyp<0) then return @@ -2274,6 +2286,10 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c ptyp=pm_user_type_body(context,ptyp) tk=pm_type_kind(context,ptyp) enddo + if(tk==pm_type_is_param) then + ptyp=pm_type_arg(context,ptyp,1) + tk=pm_type_kind(context,ptyp) + endif if(doliteral.and.pm_type_kind(context,atyp)==pm_type_is_literal_value) then ctyp=pm_literal_type_convert(context,ptyp,atyp) endif @@ -2295,6 +2311,7 @@ function pm_literal_type_convert(context,partyp,argtyp) result(ctyp) integer,intent(in):: partyp,argtyp integer:: ctyp integer:: tk + ctyp=pm_type_arg(context,argtyp,1) tk=pm_type_kind(context,partyp) if(tk==pm_type_is_fix) then @@ -2673,7 +2690,7 @@ function pm_type_as_string(context,tno,distr) result(str) type(pm_context),pointer:: context integer,intent(in):: tno logical,intent(in),optional:: distr - character(len=1024):: str + character(len=2048):: str integer:: n str='' if(tno==0) then @@ -2970,8 +2987,9 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(')')) return case(pm_type_is_literal) + if(add_char('literal(')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) - if(add_char('_literal')) return + if(add_char(')')) return case(pm_type_is_except) call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) if(add_char(' except ')) return @@ -3090,13 +3108,25 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(add_char(trim(sym_names(name)))) return if(add_char(' ')) return call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) - case(pm_type_is_param,pm_type_is_params) + case(pm_type_is_params) if(pm_opts%show_details) then - if(add_char('{')) return + if(add_char('[[=')) return + if(add_char(trim(pm_int_as_string(pm_tv_name(tv))))) return + if(add_char('::')) return endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) if(pm_opts%show_details) then - if(add_char('}')) return + if(add_char('=]]')) return + endif + case(pm_type_is_param) + if(pm_opts%show_details) then + if(add_char('<<')) return + if(add_char(trim(pm_int_as_string(pm_tv_name(tv))))) return + if(add_char('--')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) + if(pm_opts%show_details) then + if(add_char('>>')) return endif case(pm_type_is_gated) if(pm_opts%show_details) then @@ -3186,6 +3216,14 @@ function show_equiv(name,templ,typ) result(ok) integer:: i,m,name2 logical:: tuple params=-1 + +!!$ if(add_char('<%')) return +!!$ call pm_type_to_string(context,templ,str,n) +!!$ if(add_char('%>')) return +!!$ +!!$ ok=.false. +!!$ return + ok=pm_type_extract_params(context,templ,typ,params) if(ok) then m=0 @@ -3201,6 +3239,7 @@ function show_equiv(name,templ,typ) result(ok) if(n>len(str)-10) return if(m>0) then if(add_char(merge('[','(',tuple))) return + if(tuple) m=m-1 do i=1,m if(params(i)>0) then call pm_type_to_string(context,params(i),str,n) diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 1429a6f..ea7680c 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -1347,7 +1347,8 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_andnot_ve,0,3,1,ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + ! Use arg_slot here as this is a single-use variable we are using later + call wc(wcd,arg_slot(wcd,cnode_arg(args,3))) break=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) call release_var(wcd,new_ve) if(break) call wcode_error(wcd,callnode,& From c262d979be1a16559aca71b84a2e7a54295e3c73 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 6 Jun 2025 16:53:22 +0100 Subject: [PATCH 24/36] Updates to config --- config/sysdep.f90 | 130 ++++++++++++++++++++++++++++++++++------------ 1 file changed, 96 insertions(+), 34 deletions(-) diff --git a/config/sysdep.f90 b/config/sysdep.f90 index 0a8d983..7ff39a5 100644 --- a/config/sysdep.f90 +++ b/config/sysdep.f90 @@ -54,10 +54,13 @@ module pm_sysdep character(len=4),parameter:: pm_file_suffix='.pmm' ! Environment variable holding location of library files - character(len=15),parameter:: pm_env_var='PMMLIB' + character(len=12),parameter:: pm_env_var='PM_LANG_LIBS' ! Directory separator (one character only) character(len=1),parameter:: pm_file_dirsep='/' + + ! Path separator (one character only) + character(len=1),parameter:: pm_lib_path_sep=':' ! Maximum size of file name integer,parameter:: pm_max_filename_size=4096 @@ -65,6 +68,9 @@ module pm_sysdep ! Character value used to signal end of file character(len=1),parameter:: pm_eof_char=achar(0) + ! Default library path + character(len=22):: pm_default_lib_path='/usr/share/pm-lang/lib' + logical:: pm_default_lib_path_set=.true. ! ************ Compiler defaults **************** integer,parameter:: pm_default_ftn_dims=15 @@ -180,16 +186,42 @@ module pm_sysdep contains - function pm_argc() result(n) - integer:: n - n=iargc() - end function pm_argc + function pm_argc() result(n) + integer:: n + n=command_argument_count() + end function pm_argc + + subroutine pm_getarg(n,str) + integer,intent(in)::n + character(len=*):: str + call get_command_argument(n,str) + end subroutine pm_getarg + + subroutine pm_get_env_var(varname,str,ok) + character(len=*):: varname,str + logical:: ok + integer:: status + call get_environment_variable(varname,str,status=status) + ok=status==0 + end subroutine pm_get_env_var - subroutine pm_getarg(n,str) - integer,intent(in)::n - character(len=*):: str - call getarg(n,str) - end subroutine pm_getarg +!!$ function pm_argc() result(n) +!!$ integer:: n +!!$ n=iargc() +!!$ end function pm_argc +!!$ +!!$ subroutine pm_getarg(n,str) +!!$ integer,intent(in)::n +!!$ character(len=*):: str +!!$ call getarg(n,str) +!!$ end subroutine pm_getarg + +!!$ subroutine pm_get_env_var(varname,str,ok) +!!$ character(len=*):: varname,str +!!$ logical:: ok +!!$ call getenv(varname,str) +!!$ ok=str/=' ' +!!$ end subroutine pm_get_env_var function pm_isatty(l) result(ok) integer,intent(in)::l @@ -204,29 +236,59 @@ end function pm_isatty ! ok=pm_colour_messages ! end function pm_isatty - subroutine pm_module_filename(inbuffer,buffer) - character(len=*):: inbuffer,buffer - integer:: n,m - character(len=pm_max_filename_size):: libpath - buffer=inbuffer - n=len_trim(buffer) - if(n>len(pm_file_suffix)) then - if(buffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) return - endif - if(buffer(1:4)=='lib.') then - call get_environment_variable(pm_env_var,libpath) - m=len_trim(libpath) - if(m>0) then - buffer(m+1:m+n)=buffer(1:n) - buffer(1:m)=libpath - endif - endif - do m=1,n - if(buffer(m:m)=='.') then - buffer(m:m)=pm_file_dirsep - endif - enddo - buffer(n+1:n+len(pm_file_suffix))=pm_file_suffix - end subroutine pm_module_filename + subroutine pm_module_filename(inbuffer,buffer,lib_path_set,lib_path) + character(len=*),intent(in):: inbuffer,lib_path + character(len=*),intent(out):: buffer + logical,intent(in):: lib_path_set + integer:: n,m,i,tot,pathlen + logical:: ok + n=len_trim(inbuffer) + if(n>len(pm_file_suffix)) then + if(inbuffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) return + endif + if(inbuffer(1:4)=='lib.'.and.lib_path_set) then + i=1 + do + m=index(lib_path(i:),pm_lib_path_sep) +!!$ write(*,*) 'm=',m,trim(lib_path(i:m-1)) + if(m==0) then + m=len_trim(lib_path) + else + m=m+i-2 + endif + if(m>=i) then + pathlen=m-i+1 + tot=pathlen+n-3 + if(tot+len(pm_file_suffix)>len(buffer)) return + buffer(1:pathlen)=lib_path(i:m) + do i=4,n + if(inbuffer(i:i)=='.') then + buffer(i+pathlen-3:i+pathlen-3)=pm_file_dirsep + else + buffer(i+pathlen-3:i+pathlen-3)=inbuffer(i:i) + endif + enddo + buffer(tot+1:)=pm_file_suffix +!!$ write(*,*) 'TRY:',trim(buffer) + inquire(file=trim(buffer),exist=ok) + if(ok) return + else + exit + endif + if(m+2>len(lib_path)) exit + i=m+2 + end do + endif + do m=1,n + if(inbuffer(m:m)=='.') then + buffer(m:m)=pm_file_dirsep + else + buffer(m:m)=inbuffer(m:m) + endif + end do + if(n+len(pm_file_suffix)<=len(buffer)) then + buffer(n+1:)=pm_file_suffix + endif + end subroutine pm_module_filename end module pm_sysdep From 518339678b43956d4dd04cd64001d662838a576a Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Tue, 10 Jun 2025 10:53:58 +0100 Subject: [PATCH 25/36] fmt operator --- lib/sys/pm.pmm | 10 ++- src/array.f90 | 213 ++++++++++++++++++++++++++++--------------------- src/main.f90 | 2 +- src/memory.f90 | 40 +++++++++- src/parlib.f90 | 4 +- src/types.f90 | 9 ++- src/vm.f90 | 37 ++++++++- src/vmdefs.f90 | 67 ++++++++++++++-- 8 files changed, 275 insertions(+), 107 deletions(-) diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index eedaf85..7d44c2c 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -171,6 +171,7 @@ PM__intrinsic max(int,int)->(int) : "max_ln" PM__intrinsic min(int,int)->(int) : "min_ln" PM__intrinsic -(int)->(int) : "uminus_ln" PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic fmt(int,int)->(string) : "fmt_ln" PM__intrinsic sint(int)->(sint) : "int_ln" PM__intrinsic sreal(int)->(sreal) : "real_ln" PM__intrinsic real(int)->(real) : "double_ln" @@ -215,6 +216,7 @@ PM__intrinsic max(lint,lint)->(lint) : "max_offset" PM__intrinsic min(lint,lint)->(lint) : "min_offset" PM__intrinsic -(lint)->(lint) : "uminus_offset" PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic fmt(lint,int)->(string) : "fmt_offset" PM__intrinsic sint(lint)->(sint) : "int_offset" PM__intrinsic sreal(lint)->(sreal) : "real_offset" PM__intrinsic real(lint)->(real) : "double_offset" @@ -388,6 +390,7 @@ PM__intrinsic max(int64,int64)->(int64) : "max_i64" PM__intrinsic min(int64,int64)->(int64) : "min_i64" PM__intrinsic -(int64)->(int64) : "uminus_i64" PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic fmt(int64,int)->(string) : "fmt_i64" PM__intrinsic sint(int64)->(sint) : "int_i64" PM__intrinsic sreal(int64)->(sreal) : "real_i64" PM__intrinsic real(int64)->(real) : "double_i64" @@ -423,6 +426,7 @@ PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" PM__intrinsic -(sreal)->(sreal) : "uminus_r" PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic _fmt(sreal,int,int)->(string) : "fmt_dp_r" PM__intrinsic strunc(sreal)->(sint) : "int_r" PM__intrinsic trunc(sreal)->(int) : "long_r" PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" @@ -469,6 +473,7 @@ PM__intrinsic max(real,real)->(real) : "max_d" PM__intrinsic min(real,real)->(real) : "min_d" PM__intrinsic -(real)->(real) : "uminus_d" PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic _fmt(real,int,int)->(string) : "fmt_dp_d" PM__intrinsic strunc(real)->(sint) : "int_d" PM__intrinsic trunc(real)->(int) : "long_d" PM__intrinsic ltrunc(real)->(lint) : "offset_d" @@ -567,7 +572,9 @@ proc lint(x:any_real)=lint(0) :compile_error("Cannot convert real to integer") proc cpx(x:real_num)=cpx(real(x)) proc scpx(x:real_num)=cpx(sreal(x)) proc string(x:any_int)=string(int64(x)) -proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc fmt(x:real_num,f:[int,int])=_fmt(x,f.1,f.2) +proc fmt(x:real_num,f:int)=_fmt(x,f,max(1,abs(f)-6)) proc int(x:fix(int))=x @@ -1454,6 +1461,7 @@ PM__intrinsic<> _array(x:any,y:any,z:any)->(=x) : "array" PM__intrinsic<> _varray(x:any,y:any,z:any)->(=x) : "var_array" + PM__intrinsic _array_mshape(x:any^any)->(=x) : "get_dom" PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" diff --git a/src/array.f90 b/src/array.f90 index e550949..853f528 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -4507,18 +4507,19 @@ end function index_vector_nested !============================================================================= ! Apply fmt to each element of v to create vector of strings !============================================================================= - function vector_make_string(context,ve,v,buf_size,fmt) result(str) + function vector_make_string(context,ve,v,buf_size,fmt,wid,ndp) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: ve,v integer,intent(in):: buf_size + type(pm_ptr),intent(in),optional:: wid,ndp type(pm_ptr):: str - integer(pm_ln):: vsize,esize,i,j,jj,k + integer(pm_ln):: vsize,esize,i,j,jj,k,n interface - subroutine fmt(xv,xk,xs) + subroutine fmt(xv,xk,xn,xs) use pm_kinds use pm_memory type(pm_ptr),intent(in):: xv - integer(pm_ln),intent(in):: xk + integer(pm_ln),intent(in):: xk,xn character(len=*),intent(out):: xs end subroutine fmt end interface @@ -4536,9 +4537,15 @@ end subroutine fmt j=0 do i=0,vsize k=ve%data%ln(ve%offset+i) - call fmt(v,k,mess) - vec%data%ptr(vec%offset+k)=pm_new_string(context,trim(mess)) - len%data%ln(len%offset+k)=len_trim(mess) + if(present(ndp)) n=ndp%data%ln(ndp%offset+k) + call fmt(v,k,n,mess) + if(present(wid)) then + vec%data%ptr(vec%offset+k)=pm_new_string_of_width(context,trim(mess),wid%data%ln(wid%offset+k)) + len%data%ln(len%offset+k)=abs(wid%data%ln(wid%offset+k)) + else + vec%data%ptr(vec%offset+k)=pm_new_string(context,trim(mess)) + len%data%ln(len%offset+k)=len_trim(mess) + endif enddo str=make_array(context,pm_array_type,int(pm_string_type),vec,len,len,off) call pm_delete_register(context,reg) @@ -4546,6 +4553,113 @@ end subroutine fmt include 'fesize.inc' end function vector_make_string + ! Integer format + subroutine fmt_i(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=10):: mess + mess=' ' + write(mess,'(i10)') v%data%i(v%offset+n) + str=adjustl(mess) + end subroutine fmt_i + + ! Long integer format + subroutine fmt_ln(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=20):: mess + mess=' ' + write(mess,'(i20)') v%data%ln(v%offset+n) + str=adjustl(mess) + end subroutine fmt_ln + + + subroutine fmt_lln(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=25):: mess + mess=' ' + write(mess,'(i25)') v%data%lln(v%offset+n) + str=adjustl(mess) + end subroutine fmt_lln + + subroutine fmt_i32(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=10):: mess + mess=' ' + write(mess,'(i10)') v%data%i32(v%offset+n) + str=adjustl(mess) + end subroutine fmt_i32 + + subroutine fmt_i64(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=20):: mess + mess=' ' + write(mess,'(i20)') v%data%i64(v%offset+n) + str=adjustl(mess) + end subroutine fmt_i64 + + subroutine fmt_r(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=15):: mess + mess=' ' + write(mess,'(g15.8)') v%data%r(v%offset+n) + str=adjustl(mess) + end subroutine fmt_r + + subroutine fmt_d(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=25):: mess + mess=' ' + write(mess,'(g25.15)') v%data%d(v%offset+n) + str=adjustl(mess) + end subroutine fmt_d + + subroutine fmt_l(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + if(v%data%l(v%offset+n)) then + str='TRUE ' + else + str='FALSE ' + endif + end subroutine fmt_l + + subroutine fmt_r_dp(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=15):: mess,fmt + mess=' ' + write(fmt,'("(G15.",i2,")")') min(abs(m),10) + write(mess,fmt=fmt) v%data%r(v%offset+n) + str=adjustl(mess) + end subroutine fmt_r_dp + + subroutine fmt_d_dp(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=25):: mess,fmt + mess=' ' + write(fmt,'("(G25.",i2,")")') min(abs(m),20) + write(mess,fmt=fmt) v%data%d(v%offset+n) + str=adjustl(mess) + end subroutine fmt_d_dp + + !================================================================================= ! Concatenate strings in each element of v1 and v2: str <- v1 ++ v2 masked by ve ! -- ve must be shrunk @@ -4650,91 +4764,6 @@ function make_string_vector(context,val,esize) result(str) include 'fnewnc.inc' include 'fesize.inc' end function make_string_vector - - ! Integer format - subroutine fmt_i(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=10):: mess - mess=' ' - write(mess,'(i10)') v%data%i(v%offset+n) - str=adjustl(mess) - end subroutine fmt_i - - ! Long integer format - subroutine fmt_ln(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=20):: mess - mess=' ' - write(mess,'(i20)') v%data%ln(v%offset+n) - str=adjustl(mess) - end subroutine fmt_ln - - - subroutine fmt_lln(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=25):: mess - mess=' ' - write(mess,'(i25)') v%data%lln(v%offset+n) - str=adjustl(mess) - end subroutine fmt_lln - - subroutine fmt_i32(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=10):: mess - mess=' ' - write(mess,'(i10)') v%data%i32(v%offset+n) - str=adjustl(mess) - end subroutine fmt_i32 - - subroutine fmt_i64(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=20):: mess - mess=' ' - write(mess,'(i20)') v%data%i64(v%offset+n) - str=adjustl(mess) - end subroutine fmt_i64 - - subroutine fmt_r(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=15):: mess - mess=' ' - write(mess,'(g15.8)') v%data%r(v%offset+n) - str=adjustl(mess) - end subroutine fmt_r - - subroutine fmt_d(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=25):: mess - mess=' ' - write(mess,'(g25.15)') v%data%d(v%offset+n) - str=adjustl(mess) - end subroutine fmt_d - - subroutine fmt_l(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - if(v%data%l(v%offset+n)) then - str='TRUE ' - else - str='FALSE ' - endif - end subroutine fmt_l - !!$ subroutine advance_dim(val,max,overflow,n) !!$ integer(pm_ln),dimension(*),intent(inout):: val,max diff --git a/src/main.f90 b/src/main.f90 index ba2a984..44c8b8e 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -425,7 +425,7 @@ subroutine repl(context) first=.true. do write(*,'(a)',advance='NO') 'PM> ' - read(*,*) line + read(*,'(a)') line if(line=='exit') return call parse_expr_from_string(parser,line,first) first=.false. diff --git a/src/memory.f90 b/src/memory.f90 index 8a3c3fb..da24230 100755 --- a/src/memory.f90 +++ b/src/memory.f90 @@ -42,7 +42,7 @@ module pm_memory public pm_assign_new, pm_expand, pm_ptr_assign public pm_new_as_root,pm_get_ptr_as_root, pm_copy, pm_copy_ptr, pm_assign_copy public pm_new_string, pm_concat_string, pm_strval, pm_fill_vect, & - pm_copy_obj, pm_set_obj + pm_copy_obj, pm_set_obj, pm_new_string_of_width public pm_add_root, pm_delete_root public pm_numroot, pm_delete_numroot public pm_register, pm_delete_register @@ -836,6 +836,44 @@ function pm_new_string(context,string) result(ptr) endif end function pm_new_string + ! Create new string object from FORTRAN string + function pm_new_string_of_width(context,string,width) result(ptr) + type(pm_context),pointer:: context + character(len=*),intent(in):: string + integer(pm_ln),intent(in):: width + type(pm_ptr):: ptr + integer::i,n + if(width==0) then + ptr=pm_new_string(context,"") + return + endif + ptr=pm_new(context,pm_string,abs(width)) + n=len(string) + if(n>abs(width)) then + do i=1,abs(width) + ptr%data%s(ptr%offset+i-1)='*' + enddo + return + endif + if(n>0) then + if(width<0) then + do i=1,n + ptr%data%s(ptr%offset+i-1)=string(i:i) + enddo + do i=n+1,abs(width) + ptr%data%s(ptr%offset+i-1)=' ' + enddo + else + do i=1,abs(width)-n + ptr%data%s(ptr%offset+i-1)=' ' + enddo + do i=1,n + ptr%data%s(ptr%offset+i+abs(width)-n-1)=string(i:i) + enddo + endif + endif + end function pm_new_string_of_width + ! Get FORTRAN string from PM string subroutine pm_strval(ptr,str) type(pm_ptr),intent(in):: ptr diff --git a/src/parlib.f90 b/src/parlib.f90 index de7a633..fa381b1 100644 --- a/src/parlib.f90 +++ b/src/parlib.f90 @@ -4448,9 +4448,9 @@ subroutine pm_file_write_disps(handle,buffer,offsets,noff,totsize,ierr) include 'fvkind.inc' end subroutine pm_file_write_disps - subroutine pm_file_error_string(v,n,str) + subroutine pm_file_error_string(v,n,m,str) type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n + integer(pm_ln),intent(in):: n,m character(len=*),intent(out):: str character(len=mpi_max_error_string):: mess integer:: length,ierr diff --git a/src/types.f90 b/src/types.f90 index f67f0b8..18859bd 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -2325,7 +2325,10 @@ function pm_literal_type_convert(context,partyp,argtyp) result(ctyp) ctyp=partyp endif elseif(tk==pm_type_is_literal) then - ctyp=argtyp + if(pm_type_includes(context,pm_type_arg(context,partyp,1),ctyp,& + pm_type_incl_val)) then + ctyp=argtyp + endif endif end function pm_literal_type_convert @@ -2963,6 +2966,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(pm_tv_name(tv)==0) then call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) else + if(pm_opts%show_details) then + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + if(add_char('::')) return + endif nv=pm_dict_val(context,context%tcache,int(tno,pm_ln)) if(pm_fast_vkind(nv)==pm_logical) then if(nv%data%l(nv%offset)) then diff --git a/src/vm.f90 b/src/vm.f90 index 303d74b..67d9ca0 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -1777,6 +1777,10 @@ recursive function pm_run(context,funcin,stackin,pcin,& newve=shrink_ve(context,ve,esize) call set_arg(2,vector_make_string(context,& newve,arg(3),fmt_i_width,fmt_i)) + case(op_fmt_i) + newve=shrink_ve(context,ve,esize) + call set_arg(2,vector_make_string(context,& + newve,arg(3),fmt_i_width,fmt_i,arg(4))) case(op_assign_i) if(pm_fast_vkind(ve)==pm_logical) then where(ve%data%l(ve%offset:ve%offset+esize)) @@ -2467,6 +2471,10 @@ recursive function pm_run(context,funcin,stackin,pcin,& call set_arg(2,& vector_make_string(context,& newve,arg(3),fmt_ln_width,fmt_ln)) + case(op_fmt_ln) + newve=shrink_ve(context,ve,esize) + call set_arg(2,vector_make_string(context,& + newve,arg(3),fmt_ln_width,fmt_ln,arg(4))) case(op_assign_ln) if(pm_fast_vkind(ve)==pm_null) then arg(2)%data%ln(arg(2)%offset:arg(2)%offset+esize)=& @@ -3164,6 +3172,11 @@ recursive function pm_run(context,funcin,stackin,pcin,& call set_arg(2,& vector_make_string(context,& newve,arg(3),fmt_lln_width,fmt_lln)) + case(op_fmt_offset) + newve=shrink_ve(context,ve,esize) + call set_arg(2,& + vector_make_string(context,& + newve,arg(3),fmt_lln_width,fmt_lln,arg(4))) case(op_assign_offset) if(pm_fast_vkind(ve)==pm_null) then arg(2)%data%lln(arg(2)%offset:arg(2)%offset+esize)=& @@ -5913,6 +5926,11 @@ recursive function pm_run(context,funcin,stackin,pcin,& call set_arg(2,& vector_make_string(context,& newve,arg(3),fmt_i64_width,fmt_i64)) + case(op_fmt_i64) + newve=shrink_ve(context,ve,esize) + call set_arg(2,& + vector_make_string(context,& + newve,arg(3),fmt_i64_width,fmt_i64,arg(4))) case(op_assign_i64) if(pm_fast_vkind(ve)==pm_null) then arg(2)%data%i64(arg(2)%offset:arg(2)%offset+esize)=& @@ -6598,13 +6616,18 @@ recursive function pm_run(context,funcin,stackin,pcin,& enddo endif - - - case(op_string_r) newve=shrink_ve(context,ve,esize) call set_arg(2,vector_make_string(context,& newve,arg(3),fmt_r_width,fmt_r)) + case(op_fmt_r) + newve=shrink_ve(context,ve,esize) + call set_arg(2,vector_make_string(context,& + newve,arg(3),fmt_r_width,fmt_r,arg(4))) + case(op_fmt_dp_r) + newve=shrink_ve(context,ve,esize) + call set_arg(2,vector_make_string(context,& + newve,arg(3),fmt_r_width,fmt_r_dp,arg(4),arg(5))) case(op_assign_r) if(pm_fast_vkind(ve)==pm_null) then arg(2)%data%r(arg(2)%offset:arg(2)%offset+esize)=& @@ -7645,6 +7668,14 @@ recursive function pm_run(context,funcin,stackin,pcin,& newve=shrink_ve(context,ve,esize) call set_arg(2,vector_make_string(context,& newve,arg(3),fmt_d_width,fmt_d)) + case(op_fmt_d) + newve=shrink_ve(context,ve,esize) + call set_arg(2,vector_make_string(context,& + newve,arg(3),fmt_d_width,fmt_d,arg(4))) + case(op_fmt_dp_d) + newve=shrink_ve(context,ve,esize) + call set_arg(2,vector_make_string(context,& + newve,arg(3),fmt_d_width,fmt_d_dp,arg(4),arg(5))) case(op_assign_d) if(pm_fast_vkind(ve)==pm_null) then arg(2)%data%d(arg(2)%offset:arg(2)%offset+esize)=& diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index cdff052..277812d 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -290,7 +290,8 @@ module pm_vmdefs integer,parameter:: op_i32_i = op_start_i+33 integer,parameter:: op_i64_i = op_start_i+34 integer,parameter:: op_offset_i = op_start_i+35 - integer,parameter:: op_stop_i = op_start_i+35 + integer,parameter:: op_fmt_i = op_start_i+36 + integer,parameter:: op_stop_i = op_start_i+36 integer,parameter:: op_start_ln=op_stop_i integer,parameter:: op_add_ln=op_start_ln+1 @@ -326,7 +327,8 @@ module pm_vmdefs integer,parameter:: op_i32_ln = op_start_ln+33 integer,parameter:: op_i64_ln = op_start_ln+34 integer,parameter:: op_offset_ln = op_start_ln + 35 - integer,parameter:: op_stop_ln = op_start_ln+35 + integer,parameter:: op_fmt_ln = op_start_ln + 36 + integer,parameter:: op_stop_ln = op_start_ln+36 integer,parameter:: op_start_offset=op_stop_ln integer,parameter:: op_add_offset=op_start_offset+1 @@ -362,7 +364,8 @@ module pm_vmdefs integer,parameter:: op_i32_offset = op_start_offset+33 integer,parameter:: op_i64_offset = op_start_offset+34 integer,parameter:: op_long_offset = op_start_offset+35 - integer,parameter:: op_stop_offset = op_start_offset+35 + integer,parameter:: op_fmt_offset = op_start_offset+36 + integer,parameter:: op_stop_offset = op_start_offset+36 integer,parameter:: op_start_i8=op_stop_offset integer,parameter:: op_add_i8=op_start_i8+1 @@ -506,7 +509,8 @@ module pm_vmdefs integer,parameter:: op_i32_i64 = op_start_i64+33 integer,parameter:: op_long_i64 = op_start_i64+34 integer,parameter:: op_offset_i64 = op_start_i64+35 - integer,parameter:: op_stop_i64 = op_start_i64+35 + integer,parameter:: op_fmt_i64 = op_start_i64+36 + integer,parameter:: op_stop_i64 = op_start_i64+36 integer,parameter:: op_start_r =op_stop_i64 integer,parameter:: op_add_r=op_start_r+1 @@ -553,7 +557,9 @@ module pm_vmdefs integer,parameter:: op_r64_r = op_start_r+44 integer,parameter:: op_complex_r = op_start_r+45 integer,parameter:: op_complex2_r = op_start_r+46 - integer,parameter:: op_stop_r = op_start_r+46 + integer,parameter:: op_fmt_r = op_start_r+47 + integer,parameter:: op_fmt_dp_r = op_start_r+48 + integer,parameter:: op_stop_r = op_start_r+48 integer,parameter:: op_start_d =op_stop_r integer,parameter:: op_add_d=op_start_d+1 @@ -600,7 +606,9 @@ module pm_vmdefs integer,parameter:: op_r64_d= op_start_d+44 integer,parameter:: op_complex_d = op_start_d+45 integer,parameter:: op_complex2_d = op_start_d+46 - integer,parameter:: op_stop_d = op_start_d+46 + integer,parameter:: op_fmt_d = op_start_d+47 + integer,parameter:: op_fmt_dp_d = op_start_d+48 + integer,parameter:: op_stop_d = op_start_d+48 integer,parameter:: op_start_c =op_stop_d integer,parameter:: op_add_c=op_start_c+1 @@ -1679,6 +1687,7 @@ subroutine set_op_names op_names(op_gt_i)='gt_i' op_names(op_ge_i)='ge_i' op_names(op_string_i)='string_i' + op_names(op_fmt_i)='fmt_i' op_names(op_max_i)='max_i' op_names(op_min_i)='min_i' op_names(op_assign_i)='assign_i' @@ -1713,6 +1722,7 @@ subroutine set_op_names op_names(op_gt_ln)='gt_ln' op_names(op_ge_ln)='ge_ln' op_names(op_string_ln)='string_ln' + op_names(op_fmt_ln)='fmt_ln' op_names(op_max_ln)='max_ln' op_names(op_min_ln)='min_ln' op_names(op_assign_ln)='assign_ln' @@ -1747,6 +1757,7 @@ subroutine set_op_names op_names(op_gt_offset)='gt_offset' op_names(op_ge_offset)='ge_offset' op_names(op_string_offset)='string_offset' + op_names(op_fmt_offset)='fmt_offset' op_names(op_max_offset)='max_offset' op_names(op_min_offset)='min_offset' op_names(op_assign_offset)='assign_offset' @@ -1905,6 +1916,7 @@ subroutine set_op_names op_names(op_i32_i64)='i32_i64' op_names(op_offset_i64)='offset_i64' op_names(op_long_i64)='long_i64' + op_names(op_fmt_i64)='fmt_i64' op_names(op_add_r)='add_r' op_names(op_sub_r)='sub_r' @@ -1919,6 +1931,8 @@ subroutine set_op_names op_names(op_gt_r)='gt_r' op_names(op_ge_r)='ge_r' op_names(op_string_r)='string_r' + op_names(op_fmt_r)='fmt_r' + op_names(op_fmt_dp_r)='fmt_dp_r' op_names(op_max_r)='max_r' op_names(op_min_r)='min_r' op_names(op_assign_r)='assign_r' @@ -1964,6 +1978,8 @@ subroutine set_op_names op_names(op_gt_d)='gt_d' op_names(op_ge_d)='ge_d' op_names(op_string_d)='string_d' + op_names(op_fmt_d)='fmt_d' + op_names(op_fmt_dp_d)='fmt_dp_d' op_names(op_max_d)='max_d' op_names(op_min_d)='min_d' op_names(op_assign_d)='assign_d' @@ -2131,6 +2147,7 @@ function proc_get_name(proc) result(name) name=p%data%i16(p%offset+2) end function proc_get_name + ! Return line and module of given wcode offset into proc subroutine proc_line_module(proc,offset,line,modl) type(pm_ptr),intent(in):: proc integer,intent(in):: offset @@ -2159,6 +2176,7 @@ subroutine proc_line_module(proc,offset,line,modl) include 'fesize.inc' end subroutine proc_line_module + ! Return name associated with given slot no. at given code offset function proc_slot_name(proc,offset,slot) result(name) type(pm_ptr):: proc integer:: offset,slot @@ -2194,6 +2212,43 @@ function proc_slot_name(proc,offset,slot) result(name) include 'fesize.inc' end function proc_slot_name + ! Return slot number associated with given name at given code offset + function proc_name_slot(proc,offset,name) result(slot) + type(pm_ptr):: proc + integer:: offset,name + integer:: slot + integer:: i,j,start,finish,n + type(pm_ptr):: p + integer:: k + name=0 + if(pm_is_compiling) return + p=proc%data%ptr(proc%offset+1) + j=p%offset+pm_fast_esize(p) + do + k=p%data%i16(j) + if(k/=0) then + j=j-2 + else + n=p%data%i16(j-1) + start=p%data%i16(j-2) + finish=p%data%i16(j-3) + j=j-n*2-4 + if(offset>=start.and.offset<=finish) then + do i=1,n + if(p%data%i16(j+i*2)==name) then + slot=p%data%i16(j+i*2) + exit + endif + enddo + endif + endif + if(j Date: Fri, 13 Jun 2025 15:46:49 +0100 Subject: [PATCH 26/36] Poly type combiner --- lib/sys/pm.pmm | 34 +-- src/codegen.f90 | 27 ++- src/infer.f90 | 40 ++-- src/main.f90 | 8 +- src/parser.f90 | 29 ++- src/symbol.f90 | 9 +- src/types.f90 | 545 ++++++++++++++++++++++++++++++++++++------------ 7 files changed, 514 insertions(+), 178 deletions(-) diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index 7d44c2c..1a98537 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -781,13 +781,13 @@ proc dim(t:tuple6d,n:literal(6) or [literal(6)])=t.6 proc dim(t:tuple7d,n:literal(6) or [literal(6)])=t.6 proc dim(t:tuple7d,n:literal(7) or [literal(7)])=t.7 -proc indices(x:tuple1d)=[literal(1)] -proc indices(x:tuple2d)=[literal(1),literal(2)] -proc indices(x:tuple3d)=[literal(1),literal(2),literal(3)] -proc indices(x:tuple4d)=[literal(1),literal(2),literal(3),literal(4)] -proc indices(x:tuple5d)=[literal(1),literal(2),literal(3),literal(4),literal(5)] -proc indices(x:tuple6d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6)] -proc indices(x:tuple7d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6),literal(7)] +proc indices(x:tuple1d)=[1] +proc indices(x:tuple2d)=[1,2] +proc indices(x:tuple3d)=[1,2,3] +proc indices(x:tuple4d)=[1,2,3,4] +proc indices(x:tuple5d)=[1,2,3,4,5] +proc indices(x:tuple6d)=[1,2,3,4,5,6] +proc indices(x:tuple7d)=[1,2,3,4,5,6,7] proc full_rank(x:tuple1d)=1 proc full_rank(x:tuple2d)=2 @@ -1093,15 +1093,15 @@ proc notin(x,y)=not(x in y) proc notinc(x,y)=not(x inc y) // Treat null as empty sequence in some cases -proc in(x,y:null)=literal(false) -proc in(x:null,y:null)=literal(true) +proc in(x,y:null)=false +proc in(x:null,y:null)=true // Range base type (might later expand to interface) type range_base is real_num type step_base is real_num // Range types -type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} +type range(t:range_base,hi:range_base) is rec {_lo:t,_hi:hi,_n:int} proc ..(x:range_base,y:range_base)=rec range { _lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) proc low(x:range)=x._lo @@ -1461,7 +1461,6 @@ PM__intrinsic<> _array(x:any,y:any,z:any)->(=x) : "array" PM__intrinsic<> _varray(x:any,y:any,z:any)->(=x) : "var_array" - PM__intrinsic _array_mshape(x:any^any)->(=x) : "get_dom" PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" @@ -1469,7 +1468,6 @@ proc array(x,d:extent)=_array(x,_mshape(d),size(d)) proc #'(x:any^any)=_array_mshape(x)._extent proc element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) - /* PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(=x) : "array_noinit" @@ -1772,7 +1770,7 @@ proc PM__assign(&a:any,b:any) { } PM__intrinsic PM__clone(x:any)->(=x) : "clone" -PM__intrinsic PM__make_var(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var(x:any)->(=x) : "clone" priv PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" @@ -1849,8 +1847,8 @@ PM__intrinsic error_type()->(=1) : "error_type" // Debugging PM__intrinsic<> _dump(any,any): "new_dump" -proc PM__dump(x)<>:_dump("Value:",x) -proc PM__dump(y,x)<>:if y:_dump("Value:",x) +proc PM__dump'(x)<>:_dump("Value:",x) +proc PM__dump'(y,x)<>:if y:_dump("Value:",x) /* proc PM__dump%(x)<>{ print("$"++here) @@ -1872,7 +1870,9 @@ proc old_dumpit(a) { PM__intrinsic<> old_dump_id(any): "dump_id" -proc PM__filesys()=1234 +proc PM__filesys()=1234 { + let junk= +} proc PM__check_alias(a,b) {} proc PM__lhs_and_val(a)=a @@ -1893,3 +1893,5 @@ PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_c PM__intrinsic<> PM__list_splice(x:PM__list,y:PM__list,i:literal(int),j:literal(int))->(=x):"list_splice" proc compile_error(mess:literal(string)): test mess=>false + +type PM__fix_tuple is tuple(fix(int) or range(fix(int),fix(int))) diff --git a/src/codegen.f90 b/src/codegen.f90 index 94fad17..7582981 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -136,6 +136,9 @@ module pm_codegen ! '1 type integer:: unit_type + ! Types with literals (int real bool string) + integer:: literal_types + ! Check default error message integer:: check_mess @@ -264,6 +267,15 @@ subroutine init_coder(context,coder,visibility) coder%true_literal=pm_new_literal_value_type(coder%context,coder%true) coder%false_literal=pm_new_literal_value_type(coder%context,coder%false) + call push_word(coder,pm_type_new_any) + call push_word(coder,0) + call push_word(coder,int(pm_long)) + call push_word(coder,int(pm_logical)) + call push_word(coder,int(pm_string_type)) + call push_word(coder,int(pm_double)) + call make_type(coder,6) + coder%literal_types=pop_word(coder) + coder%num_errors=0 coder%supress_errors=.false. coder%fixed=.false. @@ -3655,6 +3667,11 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,pm_type_new_fix) call push_word(coder,0) call trav_type(coder,pnode,name) + if(top_word(coder)==0) then + call defer_type_check(coder,node,pnode,& + coder%literal_types,top_word(coder),sym_fix,& + cnode_is_arg_constraint) + endif call make_type(coder,3) end select case(sym_literal) @@ -3670,13 +3687,11 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,pm_type_new_unfixed) call push_word(coder,0) call trav_type(coder,pnode,name) - typno=pm_type_strip_to_basic(coder%context,pop_word(coder)) - if(typno/=0.and.typno/=pm_long.and.typno/=pm_double.and.& - typno/=pm_logical.and.typno/=pm_string_type) then - call code_error(coder,node,'Cannot have a literal type for: '//& - trim(pm_type_as_string(coder%context,typno))) + if(top_word(coder)/=0) then + call defer_type_check(coder,node,pnode,& + coder%literal_types,top_word(coder),sym_literal,& + cnode_is_arg_constraint) endif - call push_word(coder,typno) call make_type(coder,3) end select case(sym_contains) diff --git a/src/infer.f90 b/src/infer.f90 index 5d785a0..d8f17c4 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -659,25 +659,24 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) call code_num(coder,sp_sig_setval) goto 10 case(op_clone_var) - k=cnode_get_num(procnode,bi_opcode2) + mode=cnode_get_num(procnode,bi_opcode2) rtype=atype1 - if(k/=0) rtype=pm_type_replace_mode(coder%context,rtype,k) + if(mode/=0) rtype=pm_type_for_var(coder%context,atype1,mode) call code_num(coder,sp_sig_dup) goto 10 case(op_array_get_elem,op_extractelm) rtype=pm_type_arg(coder%context,atype1,1) case(op_get_dom) rtype=pm_type_arg(coder%context,atype1,2) - write(*,*) 'dom',pm_type_as_string(coder%context,atype1) case(op_as,op_get_poly_or) rtype=pm_type_arg(coder%context,atype,3) case(op_import_varg,op_broadcast_val,& op_get_rf) rtype=atype1 case(op_clone) - k=cnode_get_num(procnode,bi_opcode2) + mode=cnode_get_num(procnode,bi_opcode2) rtype=atype1 - if(k/=0) rtype=pm_type_replace_mode(coder%context,rtype,k) + if(mode/=0) rtype=pm_type_for_var(coder%context,atype1,mode) case(op_elem) n=cnode_get_num(procnode,bi_opcode2) if(n/=0) then @@ -719,12 +718,14 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) endif endif case(op_array,op_make_array,op_pack) - rtype=pm_new_arr_type(coder%context,sym_const,atype1,& + rtype=pm_new_arr_type(coder%context,sym_const,& + pm_type_for_var(coder%context,atype1,sym_private),& pm_type_arg(coder%context,atype,3),int(pm_long)) write(*,*) 'make array',pm_type_as_string(coder%context,atype) case(op_var_array) - rtype=pm_new_arr_type(coder%context,sym_var,atype1,& - pm_type_arg(coder%context,atype,3),int(pm_long)) + rtype=pm_new_arr_type(coder%context,sym_var,& + pm_type_for_var(coder%context,atype1,sym_private),& + pm_type_for_var(coder%context,pm_type_arg(coder%context,atype,3),sym_private),int(pm_long)) case(op_redim) tv=pm_type_vect(coder%context,atype1) rtype=pm_new_arr_type(coder%context,pm_tv_name(tv),& @@ -1104,6 +1105,8 @@ subroutine inf_call(coder,cblock,callnode) '"'//trim(sym_names(sig))//& '" initial expression has wrong type for: ',& pm_fast_name(coder%context,name)) + call more_error(coder%context,'Expected: '//trim(pm_type_as_string(coder%context,tno))) + call more_error(coder%context,'Got: '//trim(pm_type_as_string(coder%context,tno2))) call inf_trace(coder) tno2=error_type endif @@ -2851,6 +2854,7 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) nomatch=.false. error=.false. flags=cnode_get_num(callnode,call_flags) + if(iand(flags,call_is_fixed)==0) then at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals)==0,ipass>=2,.false.) if(at2>0) at=at2 @@ -2864,10 +2868,16 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) new_at=at return else - at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals)==0,ipass>=2,.false.) + at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals+call_is_fixed)==0,ipass>=2,.false.) if(at2>0) then - new_at=at2 - return + if(pm_type_includes(coder%context,pt,at2,pm_type_incl_val)) then + if(debug_inference) then + write(*,*) 'Converted',trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at2)) + endif + new_at=at2 + return + endif elseif(ipass==3) then ! On third pass check for poly conversions at2=convert_poly(coder,pt,at,.false.) @@ -3235,6 +3245,11 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) if(tno1<0.or.tno2<=0) then return endif + if(debug_inference) then + write(*,*) 'Cast:',trim(pm_type_as_string(coder%context,tno2)),' to: ',trim(pm_type_as_string(coder%context,tno1)) + endif + tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.false.,.false.) + if(tno3>=0) tno2=tno3 ok=pm_type_includes(coder%context,tno1,tno2,pm_type_incl_val) if(.not.ok) then tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.true.,.false.) @@ -3255,9 +3270,10 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) if(.not.ok) then call inf_error(coder,node,& 'Value of type "'//trim(pm_type_as_string(coder%context,tno2))//& - '" cannot be cast to type "'//trim(pm_type_as_string(coder%context,tno1))//"'") + '" cannot be converted to type "'//trim(pm_type_as_string(coder%context,tno1))//"'") call inf_trace(coder) endif + if(debug_inference) write(*,*) 'Cast Converts to:',trim(pm_type_as_string(coder%context,tno2)) contains include 'fisnull.inc' end function inf_cast diff --git a/src/main.f90 b/src/main.f90 index 44c8b8e..5ca0e75 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -305,7 +305,7 @@ subroutine run_type_inference(coder) write(*,*) 'TOTAL TYPES::',pm_dict_size(context,context%tcache) endif - if(pm_opts%out_typelist.and..false.) then + if(pm_opts%out_typelist) then open(unit=4,file='types.out') save_members=pm_opts%show_members save_elems=pm_opts%show_elems @@ -314,11 +314,7 @@ subroutine run_type_inference(coder) !pm_opts%show_elems=.true. !pm_opts%show_variants=.true. do i=1,pm_dict_size(context,context%tcache) - write(4,*) 'TYPE',i,pm_type_kind(context,i) - write(4,*) i,trim(pm_type_as_string(context,i)) - call pm_dump_tree(context,4,pm_type_val(context,i),2) - call dump_type(context,4,i) - write(4,*) 'DONE',i + write(4,*) iand(pm_type_flags(context,i),pm_type_has_storage)/=0,iand(pm_type_flags(context,i),pm_type_has_fix)/=0,trim(pm_type_as_string(context,i)) enddo pm_opts%show_members=save_members pm_opts%show_elems=save_elems diff --git a/src/parser.f90 b/src/parser.f90 index 24d7b48..64836ba 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -243,6 +243,9 @@ subroutine dcl_type(parser,def,line) endif end subroutine dcl_type + !====================================================== + ! Parse expression in string (for REPL) + !====================================================== subroutine parse_expr_from_string(parser,line,use_sysmod) type(parse_state),intent(inout):: parser character(len=*),intent(in):: line @@ -4049,7 +4052,31 @@ recursive function typval(parser) result(iserr) call make_node(parser,sym_literal,1) case(sym_fix,sym_literal) call scan(parser) - if(sym==sym_literal.and.parser%sym/=sym_open) then + if(sym==sym_fix.and.parser%sym==sym_open_square) then + call scan(parser) + m=0 + do + if(expect(parser,sym_number)) return + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call make_node(parser,sym_fix,1) + if(parser%sym==sym_dotdot) then + call scan(parser) + if(expect(parser,sym_number)) return + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call make_node(parser,sym_fix,1) + call push_sym_val(parser,sym_range) + call make_node(parser,sym_type,3) + endif + m=m+1 + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + call push_sym_val(parser,sym_dim1+m-1) + call make_node(parser,sym_type,m+1) + if(expect(parser,sym_close_square)) return + elseif(sym==sym_literal.and.parser%sym/=sym_open) then call make_node(parser,sym_any,0) call make_node(parser,sym_literal,1) else diff --git a/src/symbol.f90 b/src/symbol.f90 index 72acb28..8488873 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -411,7 +411,8 @@ module pm_symbol integer,parameter:: sym_init_var = hook + 63 integer,parameter:: sym_init_const = hook + 64 integer,parameter:: sym_print = hook + 65 - integer,parameter:: hook1 = hook + 65 + integer,parameter:: sym_fix_tuple = hook + 66 + integer,parameter:: hook1 = hook + 66 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -435,7 +436,8 @@ module pm_symbol integer,parameter:: sym_dim5= hook1 + 20 integer,parameter:: sym_dim6= hook1 + 21 integer,parameter:: sym_dim7= hook1 + 22 - integer,parameter:: hook2= hook1+22 + integer,parameter:: sym_range = hook1 + 23 + integer,parameter:: hook2= hook1+23 integer,parameter:: sym_generate = hook2 + 1 integer,parameter:: sym_broadcast = hook2 +2 @@ -890,6 +892,7 @@ module pm_symbol data sym_names(sym_init_var) /'PM__init_var'/ data sym_names(sym_init_const) /'PM__init_const'/ data sym_names(sym_print) /'print'/ + data sym_names(sym_fix_tuple) /'PM__fix_tuple'/ data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ @@ -915,6 +918,8 @@ module pm_symbol data sym_names(sym_dim5) /'tuple5d'/ data sym_names(sym_dim6) /'tuple6d'/ data sym_names(sym_dim7) /'tuple7d'/ + + data sym_names(sym_range) /'range'/ data sym_names(sym_generate) /'PM__generate'/ data sym_names(sym_broadcast) /'PM__broadcast'/ diff --git a/src/types.f90 b/src/types.f90 index 18859bd..649e635 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -42,19 +42,21 @@ module pm_types integer,parameter:: pm_type_has_poly=256 integer,parameter:: pm_type_has_generic=512 integer,parameter:: pm_type_has_vect=1024 - integer,parameter:: pm_type_has_fix_or_literal=2048 + integer,parameter:: pm_type_has_fix=2048 integer,parameter:: pm_type_has_params=4096 - integer,parameter:: pm_type_is_soa=8192 - integer,parameter:: pm_type_is_aos=16384 - integer,parameter:: pm_type_is_seq=32768 - integer,parameter:: pm_type_leaves=65536 + integer,parameter:: pm_type_is_recursive=8192 + integer,parameter:: pm_type_is_soa=16384 + integer,parameter:: pm_type_is_aos=32768 + integer,parameter:: pm_type_is_seq=65536 + integer,parameter:: pm_type_leaves=131072 - integer,parameter:: pm_type_is_when=8192 - integer,parameter:: pm_type_is_yield=16384 - integer,parameter:: pm_type_is_list=32768 + integer,parameter:: pm_type_is_when=16384 + integer,parameter:: pm_type_is_yield=32768 + integer,parameter:: pm_type_is_list=65536 ! Bitwise-or of flags which are not taints (only one so far) - integer,parameter:: pm_type_flags_untainting = pm_type_is_list + pm_type_is_when + pm_type_is_yield + & + integer,parameter:: pm_type_flags_untainting = & + pm_type_is_list + pm_type_is_when + pm_type_is_yield + & pm_type_is_soa + pm_type_is_aos + pm_type_is_seq ! Type kind + default flags @@ -70,7 +72,7 @@ module pm_types integer,parameter:: pm_type_new_any=10+pm_type_has_generic integer,parameter:: pm_type_new_poly=11+pm_type_has_poly+& pm_type_has_storage - integer,parameter:: pm_type_new_fix_value=12 + integer,parameter:: pm_type_new_fix_value=12+pm_type_has_fix integer,parameter:: pm_type_new_contains=13 integer,parameter:: pm_type_new_fix=14 integer,parameter:: pm_type_new_dref=15 @@ -446,7 +448,7 @@ end function pm_new_arr_type !========================= ! Create type a or b !========================= - function pm_type_combine(context,a,b) result(tno) + function pm_type_union(context,a,b) result(tno) type(pm_context),pointer:: context integer,intent(in):: a,b integer:: tno @@ -467,7 +469,7 @@ function pm_type_combine(context,a,b) result(tno) args(3)=a args(4)=b tno=pm_new_type(context,args) - end function pm_type_combine + end function pm_type_union !========================================== ! Create new polymorphic type: @etype @@ -867,13 +869,13 @@ end function pm_user_type_lookup !==================================================== ! Lookup parameterless user type with given name !==================================================== - function pm_user_type_lookup_by_name(context,name) result(tno) + function pm_user_type_lookup_by_name(context,mod,name) result(tno) type(pm_context),pointer:: context - integer,intent(in):: name + integer,intent(in):: mod,name integer:: tno integer:: arr(2) arr(1)=pm_type_new_user - arr(2)=name + arr(2)=pm_name2(context,-mod,name) tno=pm_user_type_lookup(context,arr) end function pm_user_type_lookup_by_name @@ -1081,7 +1083,7 @@ end function pm_type_replace_mode ! Error codes: ! combined_mode=-1,-2... ! Shared distributed value not allowed for position -combined_mode - ! shared_ok -- permissible to have an argumnet with 'shared' mode + ! shared_ok -- permissible to have an argument with 'shared' mode !============================================================================================ function pm_type_combine_modes(context,array,is_cond,shared_ok) result(combined_mode) type(pm_context),pointer:: context @@ -1813,7 +1815,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& if(params(nt)==-1) then params(nt)=q else - params(nt)=pm_type_combine(context,params(nt),q) + params(nt)=pm_type_union(context,params(nt),q) endif endif case(pm_type_is_vect,pm_type_is_uninitialised) @@ -2290,6 +2292,10 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c ptyp=pm_type_arg(context,ptyp,1) tk=pm_type_kind(context,ptyp) endif + do while(tk==pm_type_is_user) + ptyp=pm_user_type_body(context,ptyp) + tk=pm_type_kind(context,ptyp) + enddo if(doliteral.and.pm_type_kind(context,atyp)==pm_type_is_literal_value) then ctyp=pm_literal_type_convert(context,ptyp,atyp) endif @@ -2300,6 +2306,7 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c ctyp=pm_poly_type_convert(context,ptyp,atyp) endif ctyp=pm_type_add_mode(context,ctyp,amode) + !write(*,*) 'To:',trim(pm_type_as_string(context,ctyp)) end function pm_type_convert @@ -2324,11 +2331,8 @@ function pm_literal_type_convert(context,partyp,argtyp) result(ctyp) if(pm_type_name(context,partyp)==pm_type_name(context,argtyp)) then ctyp=partyp endif - elseif(tk==pm_type_is_literal) then - if(pm_type_includes(context,pm_type_arg(context,partyp,1),ctyp,& - pm_type_incl_val)) then - ctyp=argtyp - endif + elseif(tk==pm_type_is_literal.or.tk==pm_type_is_literal_value) then + ctyp=argtyp endif end function pm_literal_type_convert @@ -2506,9 +2510,11 @@ recursive function pm_type_find_elem(context,tno,nametype,change,etype) result(o end select end function pm_type_find_elem + !================================================================ ! Find offset and type for named element in struct/rec type ! Returns offset and type of element ! If no such element offset=0 + !================================================================ subroutine pm_type_elem_offset(context,tv,name,change,offset,etyp) type(pm_context),pointer:: context type(pm_ptr),intent(in):: tv @@ -2537,7 +2543,9 @@ subroutine pm_type_elem_offset(context,tv,name,change,offset,etyp) include 'fesize.inc' end subroutine pm_type_elem_offset + !================================================================ ! Concrete only version of a type (used/usable only for returns from builtin functions) + !================================================================ recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno @@ -2589,30 +2597,29 @@ recursive subroutine remake(n) end subroutine remake end function pm_type_as_concrete - ! Create a new type with with all literal values replaced by fix (if tofix is true) - ! Otherwise all fix values are changed to literal values - recursive function pm_type_change_fix_literal(context,tno,tofix) result(typ) + !================================================================ + ! Create a new type with with all fix values converted + ! to base type and mode changed to new_mode + !================================================================ + recursive function pm_type_for_var(context,tno,new_mode) result(typ) type(pm_context),pointer:: context - integer,intent(in):: tno - logical,intent(in):: tofix + integer,intent(in):: tno,new_mode integer:: typ type(pm_ptr):: tv integer:: tk typ=tno tv=pm_type_vect(context,tno) - if(iand(pm_tv_flags(tv),pm_type_has_fix_or_literal)==0) return + if(iand(pm_tv_flags(tv),pm_type_has_fix)==0) return tk=pm_tv_kind(tv) select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,pm_type_for_var(context,pm_tv_arg(tv,1),new_mode),new_mode) case(pm_type_is_user) typ=pm_user_type_body(context,tno) case(pm_type_is_rec) call remake(pm_tv_numargs(tv)) - case(pm_type_is_literal_value) - if(tofix) typ=pm_new_fix_value_type(context,pm_type_val(context,tno),& - pm_tv_name(tv)) case(pm_type_is_fix_value) - if(.not.tofix) typ=pm_new_literal_value_type(context,pm_type_val(context,tno),& - pm_tv_name(tv)) + typ=pm_tv_arg(tv,1) end select contains recursive subroutine remake(n) @@ -2622,13 +2629,258 @@ recursive subroutine remake(n) a(1)=tk a(2)=pm_tv_name(tv) do i=1,n - a(i+2)=pm_type_change_fix_literal(context,pm_tv_arg(tv,i),tofix) + a(i+2)=pm_type_for_var(context,pm_tv_arg(tv,i),new_mode) enddo typ=pm_new_type(context,a) end subroutine remake - end function pm_type_change_fix_literal + end function pm_type_for_var + + !================================================================ + ! Combine two types for the same variable - must be the same type + ! except for poly values which are merged + !================================================================ + recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno,tno2 + logical,intent(out):: ok,added + integer:: typ + type(pm_ptr):: tv,tv2 + integer:: tk,tk2 + + ok=.true. + added=.false. + if(tno<0) then + typ=tno2 + return + endif + typ=tno + if(tno2<0.or.tno==tno2) return + tv=pm_type_vect(context,tno) + tv2=pm_type_vect(context,tno2) + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0.or.& + iand(pm_tv_flags(tv2),pm_type_has_poly)==0) then + ok=.false. + return + endif + tk=pm_tv_kind(tv) + tk2=pm_tv_kind(tv2) + select case(tk2) + case(pm_type_is_par_kind) + if(tk==pm_type_is_par_kind) then + typ=pm_type_add_mode(context,pm_type_combine(context,pm_tv_arg(tv,1),pm_tv_arg(tv2,1),ok,added),pm_tv_name(tv2)) + else + typ=pm_type_add_mode(context,pm_type_combine(context,tno,pm_tv_arg(tv2,1),ok,added),pm_tv_name(tv2)) + return + endif + case(pm_type_is_user) + typ=pm_type_combine(context,tno,pm_user_type_body(context,tno2),ok,added) + return + end select + + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,pm_type_combine(context,& + pm_tv_arg(tv,1),tno2,ok,added),pm_tv_name(tv)) + case(pm_type_is_user) + typ=pm_type_combine(context,pm_user_type_body(context,tno),tno2,ok,added) + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) + if(tk/=tk2.or.pm_tv_name(tv)/=pm_tv_name(tv2)) then + ok=.false. + typ=-1 + return + endif + call remake(pm_tv_numargs(tv)) + case(pm_type_is_poly) + if(tk/=tk2.or.pm_tv_name(tv)/=pm_tv_name(tv2)) then + ok=.false. + typ=-1 + return + endif + call combine_poly(pm_tv_numargs(tv),pm_tv_numargs(tv2)) + case default + typ=-1 + ok=.false. + end select + contains + + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=tk + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_combine(context,pm_tv_arg(tv,i),pm_tv_arg(tv2,i),ok,added) + if(.not.ok) then + typ=-1 + return + endif + enddo + typ=pm_new_type(context,a) + end subroutine remake + + recursive subroutine combine_poly(n,n2) + integer,intent(in):: n,n2 + integer,dimension(n+n2+2):: a + logical,dimension(n):: mask + integer:: i,j,m,recur + a(1)=tk + a(2)=pm_tv_name(tv) + do j=1,n + a(2+j)=pm_tv_arg(tv,j) + enddo + + ! Merge the two lists of concrete types + m=2+n + mask=.false. + outer:do i=1,n2 + do j=1,n + if(.not.mask(j)) then + if(pm_type_includes(context,a(2+j),& + pm_tv_arg(tv2,i),pm_type_incl_val)) then + mask(j)=.true. + cycle outer + endif + endif + enddo + added=.true. + m=m+1 + a(m)=pm_tv_arg(tv2,i) + enddo outer + + ! Nothing added so just return + if(.not.added) then + typ=tno + return + endif + + ! Handle the merging of recursive poly types + recur=-1 + do i=3,m + if(iand(pm_type_flags(context,a(i)),& + pm_type_has_poly+pm_type_is_recursive)/=0) then + if(recur<0) then + recur=pm_type_new_recursive_ref(context) + endif + a(i)=pm_type_move_recursive(context,a(i),recur) + endif + enddo + + ! Create new type + typ=pm_new_type(context,a(1:m)) + if(recur>0) call pm_type_set_recursive_ref(context,recur,typ) + end subroutine combine_poly + + end function pm_type_combine + + !============================================= + ! Create new (incomplete) recursive reference + !============================================= + function pm_type_new_recursive_ref(context) result(tno) + type(pm_context),pointer:: context + integer:: tno + integer,dimension(2):: arr + arr(1)=pm_type_is_user+pm_type_is_recursive + arr(2)=-pm_dict_size(context,context%tcache) + tno=pm_new_basic_type(context,arr,& + val=pm_fast_typeno(context,0)) + contains + include 'ftypeno.inc' + end function pm_type_new_recursive_ref + + !============================================== + ! Make recursive referenc point to given type + !============================================== + subroutine pm_type_set_recursive_ref(context,typ,tno) + type(pm_context),pointer:: context + integer,intent(in):: typ,tno + call pm_type_set_val(context,typ,& + pm_fast_typeno(context,tno)) + contains + include 'ftypeno.inc' + end subroutine pm_type_set_recursive_ref - ! Get vector of integer representation of type + !================================================================ + ! Create a new type with with all fix values converted + ! to base type and mode changed to new_mode + !================================================================ + recursive function pm_type_move_recursive(context,tno,recur) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno,recur + integer:: typ + type(pm_ptr):: tv + integer:: tk + typ=tno + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_is_recursive)==0) return + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,& + pm_type_move_recursive(context,pm_tv_arg(tv,1),recur),pm_tv_name(tv)) + case(pm_type_is_user) + typ=recur + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) + call remake(pm_tv_numargs(tv)) + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=tk + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_move_recursive(context,pm_tv_arg(tv,i),recur) + enddo + typ=pm_new_type(context,a) + end subroutine remake + end function pm_type_move_recursive + + !================================================================ + ! Strip all poly types in a given types down to just the constaint + ! with no membership information + !================================================================ + recursive function pm_type_poly_base(context,tno) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: typ + type(pm_ptr):: tv + integer:: tk,arr(2) + typ=tno + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0) return + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,& + pm_type_poly_base(context,pm_tv_arg(tv,1)),pm_tv_name(tv)) + case(pm_type_is_user) + typ=pm_user_type_body(context,tno) + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) + call remake(pm_tv_numargs(tv)) + case(pm_type_is_poly) + arr(1)=pm_type_new_poly + arr(2)=pm_tv_name(tv) + typ=pm_new_type(context,arr) + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=tk + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_poly_base(context,pm_tv_arg(tv,i)) + enddo + typ=pm_new_type(context,a) + end subroutine remake + end function pm_type_poly_base + + !================================================================ + ! Get vector-of-integer representation of type + !================================================================ function pm_type_vect(context,tno) result(typ) type(pm_context),pointer:: context integer,intent(in):: tno @@ -2645,28 +2897,36 @@ function pm_type_vect(context,tno) result(typ) typ=pm_dict_key(context,dict,t) end function pm_type_vect + !================================================================ ! Type kind from integer type vector + !================================================================ function pm_tv_kind(typ) result(k) type(pm_ptr),intent(in):: typ integer:: k k=iand(typ%data%i(typ%offset),pm_type_kind_mask) end function pm_tv_kind - ! Type kind from integer type vector + !================================================================ + ! Type flags from integer type vector + !================================================================ function pm_tv_flags(typ) result(k) type(pm_ptr),intent(in):: typ integer:: k k=typ%data%i(typ%offset) end function pm_tv_flags - ! Name from integer type vector + !================================================================ + ! Type name field from integer type vector + !================================================================ function pm_tv_name(typ) result(name) type(pm_ptr),intent(in):: typ integer:: name name=typ%data%i(typ%offset+1_pm_p) end function pm_tv_name - ! Argument m from integer type vector + !================================================================ + ! Type argument m from integer type vector + !================================================================ function pm_tv_arg(typ,m) result(arg) type(pm_ptr),intent(in):: typ integer,intent(in):: m @@ -2678,8 +2938,10 @@ function pm_tv_arg(typ,m) result(arg) endif arg=typ%data%i(typ%offset+m+1) end function pm_tv_arg - - ! Number of arguments in integer type vector + + !================================================================ + ! Number of type arguments from integer type vector + !================================================================ function pm_tv_numargs(typ) result(num) type(pm_ptr),intent(in):: typ integer:: num @@ -2688,11 +2950,12 @@ function pm_tv_numargs(typ) result(num) include 'fesize.inc' end function pm_tv_numargs + !================================================================ ! Display type as user-readable string - function pm_type_as_string(context,tno,distr) result(str) + !================================================================ + function pm_type_as_string(context,tno) result(str) type(pm_context),pointer:: context integer,intent(in):: tno - logical,intent(in),optional:: distr character(len=2048):: str integer:: n str='' @@ -2700,16 +2963,17 @@ function pm_type_as_string(context,tno,distr) result(str) str='any' else n=1 - call pm_type_to_string(context,tno,str,n,tuple=.false.,distr=distr) + call pm_type_to_string(context,tno,str,n) endif end function pm_type_as_string - recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,tuple_start) + recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_start) type(pm_context),pointer:: context integer,intent(in):: typno character(len=1024),intent(inout):: str integer,intent(inout):: n - logical,intent(in),optional:: distr,tuple,noequiv + !logical,intent(in),optional:: distr,tuple,noequiv + logical,intent(in),optional:: noequiv,infix integer,intent(in),optional:: tuple_start type(pm_ptr):: tv,tv2,nv,nv2 integer:: tk,narg,tno2 @@ -2720,7 +2984,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t character(len=1),parameter:: close_square = ']' integer:: i,j,istart,tno,tk2 type(pm_ptr):: amps - logical:: ok + logical:: ok,isfix if(n>len(str)-10) return tno=typno if(tno==0) then @@ -2743,45 +3007,35 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t case(pm_type_is_user,pm_type_is_basic,pm_type_is_category) name=pm_tv_name(tv) if(name<0) then - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) return endif name=pm_name_stem(context,name) if(name>=sym_dim1.and.name<=sym_dim7.and.narg==name-sym_dim1+1) then - if(present(distr)) then - if(.not.distr) return - endif - if(present(tuple)) then - tno2=pm_tv_arg(tv,1) - ok=.true. - do i=2,narg - ok=ok.and.pm_tv_arg(tv,i)==tno2 - enddo - else - ok=.false. - endif - if(ok) then - call pm_name_string(context,name,str(n:)) - n=len_trim(str)+1 - if(narg==1) then - if(add_char('(')) return - else - if(add_char('_of(')) return - endif - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) - if(add_char(')')) return - else - if(add_char('[')) return - do i=1,narg-1 - call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) - if(add_char(',')) return - enddo - call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n) - if(add_char(']')) return + isfix=pm_type_includes(context,& + pm_user_type_lookup_by_name(context,sym_pm_system,sym_fix_tuple),& + tno,pm_type_incl_type) + if(isfix) then + if(add_char('fix')) return endif + if(add_char('[')) return + do i=1,narg-1 + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,isfix) + if(add_char(',')) return + enddo + call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n,isfix) + if(add_char(']')) return elseif(name==sym_pm_ref_type) then - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) else + if(name==sym_range.and.narg==2) then + if(pm_tv_arg(tv,1)/=pm_tv_arg(tv,2)) then + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + if(add_char('..')) return + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n,infix) + return + endif + endif call pm_name_string(context,name,str(n:)) n=len_trim(str)+1 if(n>len(str)-10) return @@ -2789,10 +3043,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(narg>0) then if(add_char('(')) return do i=1,narg-1 - call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(add_char(',')) return enddo - call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n,infix) if(add_char(')')) return endif if(tk==pm_type_is_user.and.(pm_opts%show_members)) then @@ -2802,7 +3056,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t tv=pm_type_vect(context,tno2) if(pm_tv_kind(tv)/=pm_type_is_basic) then if(add_char(' {')) return - call pm_type_to_string(context,tno2,str,n) + call pm_type_to_string(context,tno2,str,n,infix) if(add_char('}')) return endif else @@ -2834,19 +3088,19 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(jlen(str)-10) return if(add_char(':')) return - call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(i0) then @@ -3042,15 +3302,15 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(pm_opts%show_variants) then if(add_char(' -- {')) return do i=1,pm_tv_numargs(tv)-1 - call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(add_char(',')) return enddo - call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n,infix) if(add_char('}')) return endif elseif(name==0) then if(add_char('proc')) return - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) else if(add_char('proc ')) return nv2=pm_name_val(context,-name) @@ -3063,7 +3323,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t endif n=len_trim(str)+1 if(n>len(str)-10) return - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) endif case(pm_type_is_proc_sig) name=pm_tv_name(tv) @@ -3086,10 +3346,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,tuple_start=istart) if(add_char('->')) return - call pm_type_to_string(context,pm_tv_arg(tv,2),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n,infix) if(iand(pm_tv_flags(tv),pm_type_is_yield)/=0) then if(add_char('yield(')) return - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) if(add_char(')')) return endif case(pm_type_is_undef_result) @@ -3106,7 +3366,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t if(pm_opts%show_details) then if(add_char('^^(')) return endif - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) if(pm_opts%show_details) then if(add_char(')')) return endif @@ -3114,7 +3374,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t name=pm_tv_name(tv) if(add_char(trim(sym_names(name)))) return if(add_char(' ')) return - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) case(pm_type_is_params) if(pm_opts%show_details) then if(add_char('[[=')) return @@ -3164,13 +3424,13 @@ recursive subroutine pm_type_to_string(context,typno,str,n,distr,tuple,noequiv,t endif case(pm_type_is_type) if(add_char('<')) return - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) if(add_char('>')) return case(pm_type_is_uninitialised) if(pm_opts%show_details) then if(add_char('UNINIT:')) return endif - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) case(pm_type_is_bottom) if(add_char(' _ ')) return case default @@ -3209,10 +3469,10 @@ subroutine bracket(i,tk1,tk2,tk3,tk4) tk=pm_type_kind(context,pm_tv_arg(tv,i)) if(tk==tk1.or.tk==tk2.or.tk==tk3.or.tk==tk4) then if(add_char('(')) return - call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(add_char(')')) return else - call pm_type_to_string(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) endif end subroutine bracket @@ -3225,7 +3485,7 @@ function show_equiv(name,templ,typ) result(ok) params=-1 !!$ if(add_char('<%')) return -!!$ call pm_type_to_string(context,templ,str,n) +!!$ call pm_type_to_string(context,templ,str,n,infix) !!$ if(add_char('%>')) return !!$ !!$ ok=.false. @@ -3239,27 +3499,41 @@ function show_equiv(name,templ,typ) result(ok) enddo name2=pm_name_stem(context,name) tuple=name2>=sym_dim1.and.name2<=sym_dim7 - if(.not.tuple) then - call pm_name_string(context,name,str(n:)) - endif - n=len_trim(str)+1 - if(n>len(str)-10) return - if(m>0) then - if(add_char(merge('[','(',tuple))) return - if(tuple) m=m-1 - do i=1,m - if(params(i)>0) then - call pm_type_to_string(context,params(i),str,n) - endif - if(ilen(str)-10) return + if(m>0) then + isfix=tuple.and.iand(pm_tv_flags(tv),& + pm_type_has_storage+pm_type_has_fix)==pm_type_has_fix + if(isfix) isfix=pm_type_includes(context,& + pm_user_type_lookup_by_name(context,sym_pm_system,sym_fix_tuple),& + tno,pm_type_incl_val) + if(isfix) then + if(add_char('fix')) return + endif + if(add_char(merge('[','(',tuple))) return + if(tuple) m=m-1 + do i=1,m + if(params(i)>0) then + call pm_type_to_string(context,params(i),str,n,isfix) + endif + if(i Date: Thu, 19 Jun 2025 15:11:19 +0100 Subject: [PATCH 27/36] Type inference for poly types --- src/codegen.f90 | 40 ++- src/infer.f90 | 643 ++++++++++++++++++++++++++++-------------------- src/types.f90 | 205 ++++++++++++--- src/wcoder.f90 | 2 +- 4 files changed, 582 insertions(+), 308 deletions(-) diff --git a/src/codegen.f90 b/src/codegen.f90 index 7582981..9dfa972 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -113,7 +113,7 @@ module pm_codegen integer:: proc_flags ! State variables (as position in coder%var) - integer:: state_base,mask + integer:: param_base,state_base,mask ! Caches for call signatures and resolved procedures type(pm_ptr):: sig_cache,proc_cache,poly_cache @@ -164,8 +164,11 @@ module pm_codegen integer:: block_entry,block_base ! Flags indicating type inference not complete - logical:: types_finished,redo_calls,incomplete,first_pass + logical:: types_finished,redo_calls,incomplete,first_pass,types_changed + ! Type inference - depth of nested loops + integer:: loop_depth + ! Taints integer:: taints,proc_taints @@ -1604,7 +1607,7 @@ subroutine make_block_proc(coder,cblock,node,namelist,amps,rtns,nret,stmtlist,it endif call code_val(coder,coder%var(base+4)) cblock3=make_cblock(coder,cblock2,stmtlist,sym_do_stmt) - coder%lex_scope=coder%lex_scope+1 + !coder%lex_scope=coder%lex_scope+1 if(present(iters)) then call extract_iter_lists(coder,cblock3,iters,iter_amps,iter_stars) @@ -1614,7 +1617,7 @@ subroutine make_block_proc(coder,cblock,node,namelist,amps,rtns,nret,stmtlist,it call trav_xexpr(coder,cblock3,node,rtns) call make_sp_call(coder,cblock3,node,sym_result,nret,0) - coder%lex_scope=coder%lex_scope-1 + !coder%lex_scope=coder%lex_scope-1 call close_cblock(coder,cblock3) call extract_block_vars(coder,cblock2,node,coder%var(base+7),.true.) @@ -2034,6 +2037,7 @@ subroutine update_change_lists(coder,var,modify) lex_scope=coder%lex_scope lex_scope_of_var=cnode_get_num(var,var_lex_scope) do while(lex_scope_of_var0) then @@ -200,8 +208,8 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& last_key_index=keys%data%i(keys%offset+pm_fast_esize(keys)) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) - call inf_key_args(coder,callnode,procnode,atype,& - nkeys,keynames,keybase,key(3:),nk) + call inf_key_args(coder,callnode,procnode,atype,& + nkeys,keynames,keybase,key_types,nk,.false.) keysize=keysize+nk elseif(nkeys>0) then call inf_error(coder,callnode,& @@ -221,6 +229,8 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& if(tno==coder%false_fix.or.tno==coder%false_literal) then call pop_stack_frame(coder) nomatch=.true. + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed return elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then call inf_error(coder,procnode,& @@ -232,10 +242,17 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& if(only_when) then call pop_stack_frame(coder) + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed nomatch=.false. return endif + ! Strip poly type membership from keyword argument types and place in lookup key + do i=3,keysize + key(i)=key_types(i-2) ! pm_type_strip_poly(coder%context,key_types(i-2)) + enddo + ! Lookup combination of proc, arg types and all key types ! defined for the procedure (including defaults) k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) @@ -247,11 +264,11 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& trim(pm_type_as_string(coder%context,atype)) endif - + ! This combination already cached if(k>0) then cnode=pm_dict_val(coder%context,coder%proc_cache,k) - + if(debug_inference) then write(*,*) 'FOUND',k,'-->',key(1:keysize) write(*,*) 'CACHED>',k,cnode%data%vkind,cnode%offset,& @@ -263,6 +280,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& if(pm_fast_istiny(cnode)) then sp_code=cnode%offset if(sp_code==sp_sig_break) then + at=atype goto 10 elseif(sp_code==sp_sig_recursive) then if(coder%flag_recursion) then @@ -290,15 +308,42 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ! Another special sig rtype=atype call code_num(coder,int(sp_code)) - else - ! Return type - rtype=sp_code - if(debug_inference) write(*,*) 'CACHED RETURN>',rtype - call code_num(coder,int(k)) - endif + endif + elseif(pm_fast_vkind(cnode)==pm_int) then + ! Return type + rtype=cnode%data%i(cnode%offset) + new_atype=cnode%data%i(cnode%offset+1) + if(debug_inference) write(*,*) 'CACHED RETURN>',rtype + call code_num(coder,int(k)) else - ! Not a special code so have a fully inferred procedure +!!$ ! Combine any polymorphic types in regular or keyword arguments +!!$ at=pm_type_combine(coder%context,cnode_get_num(cnode,4),atype,ok,added) +!!$ if(.not.ok) call pm_panic('Augmenting proc type signature in inf_proc') +!!$ if(added) new_atype=at +!!$ if(proc_nkeys>0) then +!!$ keytypes=cnode_arg(cnode,5) +!!$ do i=1,proc_nkeys +!!$ key_types(i)=pm_type_combine(coder%context,& +!!$ keytypes%data%i(keytypes%offset+i-1),& +!!$ key_types(i),key_added,ok) +!!$ added=added.or.key_added +!!$ enddo +!!$ endif +!!$ +!!$ ! New polymorphic type elements have been added +!!$ if(added) then +!!$ if(proc_nkeys>0) then +!!$ ! Keyword args and associated expressions may have polymorphic types - re-infer +!!$ vbase=coder%vtop +!!$ call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) +!!$ call inf_key_args(coder,callnode,procnode,atype,& +!!$ nkeys,keynames,keybase,key_types,nk,.true.) +!!$ endif +!!$ goto 10 +!!$ endif + + ! Not a special code and no new poly types - so have a fully inferred procedure ! Pass out taints taints=cnode_num_arg(cnode,3) @@ -314,6 +359,8 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& if(debug_inference) write(*,*) 'CACHED RTYPE>',rtype endif if(proc_nkeys>0) call pop_stack_frame(coder) + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed return endif @@ -328,6 +375,8 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call inf_error_with_trace(coder,procnode,& 'Recursion appears to require infinite types') call code_num(coder,0) + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed return endif @@ -335,17 +384,17 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ! Flag call to check for recursion call cnode_incr_num(procnode,pr_recurse,1) + + ! Get ready to type infer k=pm_idict_add(coder%context,coder%proc_cache,& key,keysize,pm_fast_tinyint(coder%context,sp_sig_in_process)) - - ! Repeatedly type infer until complete save_incomplete=coder%incomplete save_taints=coder%taints - if(proc_nkeys==0.and.pm_fast_isnull(cnode_get(procnode,pr_when))) then call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) endif - + + ! Repeatedly type infer until complete do if(debug_inference) write(*,*) 'TRY>',key(1),key(2),rtype @@ -361,64 +410,91 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ! Check procedure record for recursion/completion cnode=pm_dict_val(coder%context,coder%proc_cache,k) - if(.not.pm_fast_istiny(cnode)) then - write(*,*) cnode%data%vkind,k - call pm_panic('procnode-proc bad cache') - endif - + if(debug_inference) then write(*,*) 'TRY COMPLETE>',cnode%offset,& coder%stack(coder%base),coder%stack(coder%base-1),nret endif - sp_code=cnode%offset - if(sp_code==sp_sig_in_process) then - ! Not recursively called - rtype=coder%stack(coder%base) - if(nret==0) rtype=0 - if(debug_inference) write(*,*) 'NOT RECURSIVE>',rtype,coder%incomplete - exit - else if(sp_code<=sp_sig_recursive) then - ! Recursively called - if(nret==0) coder%stack(coder%base)=0 - - if(coder%stack(coder%base)<0) then - ! No resolved type yet - ! flag cache entry - ! and break out - call pop_stack_frame(coder) - sp_code=sp_sig_break - call pm_dict_set_val(coder%context,& - coder%proc_cache,k,cnode) - coder%incomplete=.true. - coder%taints=save_taints - rtype=error_type - if(debug_inference) write(*,*) 'NOT RESOLVED>' - return - endif + if(pm_fast_istiny(cnode)) then + sp_code=cnode%offset + if(sp_code==sp_sig_in_process) then + ! Not recursively called + rtype=coder%stack(coder%base) + new_atype=coder%stack(coder%base-3) + if(nret==0) rtype=0 + if(debug_inference) write(*,*) 'NOT RECURSIVE>',rtype,coder%incomplete + exit + else if(sp_code<=sp_sig_recursive) then + ! Recursively called + if(nret==0) coder%stack(coder%base)=0 + + if(coder%stack(coder%base)<0) then + ! No resolved type yet + ! flag cache entry + ! and break out + call pop_stack_frame(coder) + sp_code=sp_sig_break + call pm_dict_set_val(coder%context,& + coder%proc_cache,k,cnode) + coder%incomplete=.true. + coder%taints=save_taints + rtype=error_type + if(debug_inference) write(*,*) 'NOT RESOLVED>' + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed + return + endif - ! Flag procedure as recursive - coder%taints=ior(coder%taints,proc_is_recursive) + ! Flag procedure as recursive + coder%taints=ior(coder%taints,proc_is_recursive) - ! Cache resolved return type - sp_code=coder%stack(coder%base) - call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) + ! Cache resolved return type + cnode=pm_fast_newnc(coder%context,pm_int,2) + cnode%data%i(cnode%offset)=coder%stack(coder%base) + cnode%data%i(cnode%offset+1)=coder%stack(coder%base-3) + call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) + endif else ! Recursive call for which we ! already have a return type ! check against type just returned if(debug_inference) write(*,*) 'RT>',rtype,coder%stack(coder%base) - rtype=sp_code + + if(pm_fast_vkind(cnode)/=pm_int) call pm_panic('Bad cached proc kind') + + rtype=cnode%data%i(cnode%offset) + new_atype=cnode%data%i(cnode%offset+1) if(debug_inference) write(*,*) 'RECURSIVE WITH TYPE>',& - trim(pm_type_as_string(coder%context,rtype)),& + trim(pm_type_as_string(coder%context,rtype)),' FOR ',& trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) - ! This error should not happen - !(implies compiler bug as proc output type determined by args) - if(nret>0.and.rtype/=coder%stack(coder%base)) then - call inf_error_with_trace(coder,procnode,& - 'Internal Compiler Error: Procedure return type changed') + ! If returning values or updating "&" arguments, need to check if types have changed + if(nret>0.or.coder%stack(coder%base-3)/=-1) then + added=.false. + if(nret>0) then + rtype=pm_type_combine(coder%context,coder%stack(coder%base),rtype,ok,added) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Internal Compiler Error: Procedure return types changed') + endif + endif + if(coder%stack(coder%base-3)/=-1) then + new_atype=pm_type_combine(coder%context,coder%stack(coder%base-3),new_atype,ok,change_added) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Internal Compiler Error: Procedure returned "&" arg types changed') + endif + added=added.or.change_added + endif + if(added) then + cnode=pm_fast_newnc(coder%context,pm_int,2) + cnode%data%i(cnode%offset)=rtype + cnode%data%i(cnode%offset+1)=new_atype + call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) + cycle + endif endif ! Flag procedure as recursive @@ -442,6 +518,8 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& if(rtype>=0) then call code_num(coder,int(k)) endif + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed return endif @@ -457,7 +535,13 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ior(iand(cnode_get_num(procnode,pr_flags),& proccall_is_comm+proccall_is_inline+proccall_is_no_inline),& coder%taints)) - call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) + call code_num(coder,atype) + if(proc_nkeys>0) then + call code_int_vec(coder,key_types,1,nk) + else + call code_null(coder) + endif + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,5) cnode=top_code(coder) if(debug_inference) then write(*,*) 'CACHE AS>',key(1:keysize),'>',cnode%offset @@ -474,6 +558,9 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& coder%proc_taints=iand(coder%taints,proc_taints) coder%taints=ior(save_taints,coder%proc_taints) + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed + if(pm_debug_level>3) then write(*,*) 'ENDPROCNODE>',key(1),key(2),key(3),key(4),k endif @@ -523,15 +610,17 @@ end subroutine inf_arg_types ! and converting the arguments !======================================================================= subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& - keytypes,n) + key_types,n,combine) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,procnode,call_keys integer,intent(in):: atype,nkeys,key_base - integer,intent(out):: keytypes(*),n + integer,intent(out):: key_types(:),n + logical,intent(in):: combine + integer,dimension(size(key_types)):: keytypes integer i,j,cname,pname,ctype,ptype,dtype,pdtype,mtype - logical:: nomatch,error + logical:: nomatch,error,ok,added type(pm_ptr):: callkeys,proc_keys,arglist,tv - integer:: nargs,totargs,tno + integer:: nargs,totargs,tno,keytype proc_keys=cnode_get(procnode,pr_keys) @@ -595,13 +684,18 @@ subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& elseif(error) then exit else - keytypes(i)=mtype + keytype=mtype endif else - keytypes(i)=dtype + keytype=dtype + endif + if(combine) then + key_types(i)=pm_type_combine(coder%context,key_types(i),keytype,ok,added) + else + key_types(i)=keytype endif - call set_var_type(coder,cnode_arg(arglist,i),keytypes(i)) - call set_var_type(coder,cnode_arg(arglist,i+n),keytypes(i)) + call set_var_type(coder,cnode_arg(arglist,i),key_types(i)) + call set_var_type(coder,cnode_arg(arglist,i+n),key_types(i)) enddo contains include 'fesize.inc' @@ -611,16 +705,19 @@ end subroutine inf_key_args ! ================================================== ! Type infer builtin procedure ! =================================================== - function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) + function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: procnode,callnode integer,intent(in):: atype,ptype + integer,intent(out):: new_atype integer:: rtype,mode,atype1 integer,dimension(1):: key integer:: k,t1,n,opcode type(pm_ptr):: tv,v logical:: isstatic,iscomm + new_atype=-1 + if(debug_inference) then write(*,*) 'BUILTIN>',& trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) @@ -763,6 +860,8 @@ function inf_builtin(coder,procnode,callnode,atype,ptype) result(rtype) call infer_list_concat case(op_list_splice) call infer_list_splice + case(op_assign) + new_atype=pm_type_arg(coder%context,atype,3) end select ! Create cache entry @@ -912,16 +1011,15 @@ subroutine inf_call(coder,cblock,callnode) call check_loop_writes(4) list=cnode_arg(args,1) list2=cnode_arg(args,3) + coder%loop_depth=coder%loop_depth+1 counter=0 do - call clear_cblock_mark(list) - call clear_cblock_mark(list2) + coder%types_changed=.false. call inf_cblock(coder,list) call check_logical(2,sig==sym_while_invar) if(arg_type(2)==coder%false_fix) return call inf_cblock(coder,list2) - if(.not.(cblock_marked(list).or.& - cblock_marked(list2))) exit + if(.not.coder%types_changed.or.coder%loop_depth>1) exit counter=counter+1 if(counter>max_recur) then call inf_error_with_trace(coder,args,& @@ -929,15 +1027,17 @@ subroutine inf_call(coder,cblock,callnode) exit endif enddo + coder%loop_depth=coder%loop_depth-1 if(sig/=sym_while) call mark_loop_cond(5) case(sym_until,sym_until_invar,sym_each) call check_loop_writes(3) list=cnode_arg(args,1) + coder%loop_depth=coder%loop_depth+1 counter=0 do - call clear_cblock_mark(list) + coder%types_changed=.false. call inf_cblock(coder,list) - if(.not.cblock_marked(list)) exit + if(.not.coder%types_changed.or.coder%loop_depth>1) exit counter=counter+1 if(counter>max_recur) then call inf_error_with_trace(coder,args,& @@ -946,6 +1046,7 @@ subroutine inf_call(coder,cblock,callnode) endif enddo call check_logical(2,sig==sym_until_invar) + coder%loop_depth=coder%loop_depth-1 if(sig/=sym_until) call mark_loop_cond(5) case(sym_if,sym_if_invar) call inf_if(count_updates(cnode_arg(args,4),2),sig==sym_if_invar) @@ -1352,6 +1453,10 @@ subroutine inf_call(coder,cblock,callnode) call get_arg_types_and_modes call make_type_if_possible(coder,nargs+2) coder%stack(coder%base)=pop_word(coder) + case(sym_amp) + call get_arg_types_and_modes + call make_type_if_possible(coder,nargs+2) + coder%stack(coder%base-3)=pop_word(coder) case(sym_start_loop) coder%stack(get_slot(2))=pm_logical case(sym_underscore,sym_colon,sym_end_loop) @@ -1464,7 +1569,7 @@ subroutine inf_any(nupdates) integer,intent(in):: nupdates integer,dimension(nupdates):: init_var_types,final_var_types integer:: i,j,slot,slot2 - type(pm_ptr):: changelist,writelist,list,list2,var,p + type(pm_ptr):: changelist,writelist,list,list2,var,p,tv list2=cnode_arg(args,4) list2=cnode_arg(list2,1) changelist=cnode_arg(args,5) @@ -1472,9 +1577,9 @@ subroutine inf_any(nupdates) slot=list2%data%i(list2%offset) slot2=list2%data%i(list2%offset+1) tno=pm_type_strip_mode(coder%context,arg_type(3),mode) - t=check_poly(coder,tno) - if(tno/=error_type.and..not.pm_fast_isnull(t)) then - n=pm_set_size(coder%context,t) + if(tno/=error_type) then + tv=pm_type_vect(coder%context,tno) + n=pm_tv_numargs(tv) j=1 p=writelist do while(.not.pm_fast_isnull(p)) @@ -1492,11 +1597,8 @@ subroutine inf_any(nupdates) p=p%data%ptr(p%offset+1) j=j+1 end do - list=pm_set_key(coder%context,t,int(i,pm_ln)) - tno=list%data%i(list%offset) coder%stack(coder%base+slot:coder%base+slot2)=undefined - coder%stack(get_slot(1))=& - pm_type_add_mode(coder%context,tno,mode) + call set_arg_to_type(1,pm_type_add_mode(coder%context,pm_tv_arg(tv,i),mode)) call inf_cblock(coder,cnode_arg(args,2)) call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) @@ -2154,7 +2256,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass,nconsidered integer:: vbase,wbase type(pm_ptr):: tv,v,proc,match_proc,rtvect - integer:: rt,rt2,pars,mpars,apars,tno,match_pars,pflags + integer:: rt,rt2,pars,mpars,apars,new_apars,tno,match_pars,pflags logical:: ok,found,visible,found_has_no_rtypes,when_no_match integer,dimension(1):: key integer:: memo @@ -2254,7 +2356,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) endif rt=inf_proc(coder,proc,callnode,apars,pars,nret,nkey,& keynames,keybase,& - int(pm_fast_esize(cnode_get(proc,pr_keys))+1)/2,when_no_match,.true.) + int(pm_fast_esize(cnode_get(proc,pr_keys))+1)/2,when_no_match,.true.,new_apars) coder%trace_depth=coder%trace_depth-1 if(.not.when_no_match) then call inf_error(coder,callnode,& @@ -2286,7 +2388,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) ! A good match has been found ! infer the associated procedure if(cnode_get_kind(proc)==cnode_is_builtin) then - rt=inf_builtin(coder,proc,callnode,apars,pars) + rt=inf_builtin(coder,proc,callnode,apars,pars,new_apars) else pcheck=coder%vtop @@ -2301,7 +2403,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) rt=inf_proc(coder,proc,callnode,apars,pars,nret,nkey,& keynames,keybase,& - int(pm_fast_esize(cnode_get(proc,pr_keys))+1)/2,when_no_match,.false.) + int(pm_fast_esize(cnode_get(proc,pr_keys))+1)/2,when_no_match,.false.,new_apars) coder%trace_depth=coder%trace_depth-1 if(when_no_match) then cycle @@ -2352,6 +2454,21 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) enddo endif endif + if(new_apars>0.and.amps/=0) then + write(*,*) 'Changing to',trim(pm_type_as_string(coder%context,new_apars)) + amplocs=pm_name_val(coder%context,amps) + rtvect=pm_type_vect(coder%context,new_apars) + if(pm_tv_kind(rtvect)==pm_type_is_tuple.and.& + iand(pm_tv_flags(rtvect),pm_type_is_list)==0) then + do j=0,pm_fast_esize(amplocs) + m=amplocs%data%i(amplocs%offset+j) + call combine_types(cnode_arg(args,m),pm_tv_arg(rtvect,j+1)) + enddo + else + m=amplocs%data%i(amplocs%offset) + call combine_types(cnode_arg(args,m),new_apars) + endif + endif elseif(apars==error_type) then if(debug_inference) write(*,*) 'TERMINATED>' exit outer @@ -2850,6 +2967,7 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) logical,intent(out):: nomatch,error integer:: new_at integer:: at,pt2,at2,base,status,flags + logical:: converted_to_poly at=old_at nomatch=.false. error=.false. @@ -2868,26 +2986,22 @@ function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) new_at=at return else - at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals+call_is_fixed)==0,ipass>=2,.false.) + at2=pm_type_convert(coder%context,pt,at,& + iand(flags,call_keep_literals+call_is_fixed)==0,ipass>=2,ipass>=3,converted_to_poly) if(at2>0) then if(pm_type_includes(coder%context,pt,at2,pm_type_incl_val)) then if(debug_inference) then write(*,*) 'Converted',trim(pm_type_as_string(coder%context,pt)),'<>',& trim(pm_type_as_string(coder%context,at2)) endif - new_at=at2 - return - endif - elseif(ipass==3) then - ! On third pass check for poly conversions - at2=convert_poly(coder,pt,at,.false.) - if(at2/=-1) then - base=coder%wtop - call push_word(coder,ielem) - call push_word(coder,at2) - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - ! Correct parameter type to post-conversion value - coder%wtop=base + if(converted_to_poly) then + base=coder%wtop + call push_word(coder,ielem) + call push_word(coder,at2) + call code_int_vec(coder,coder%wstack,base+1,coder%wtop) + ! Correct parameter type to post-conversion value + coder%wtop=base + endif new_at=at2 return endif @@ -2928,44 +3042,51 @@ function is_visible(coder,callnode,procnode) result(ok) endif end function is_visible - subroutine new_stack_frame(coder,max_index) - type(code_state),intent(inout):: coder - integer,intent(in):: max_index - coder%stack(coder%top+1)=coder%base - coder%base=coder%top+4 - coder%top=coder%base+max_index - if(coder%top>max_code_stack) & - call pm_panic('Program too complex (nested calls)') - end subroutine new_stack_frame - ! ================================================================================ ! Set up type inference frame - ! Three control slots: + ! Five control slots: + ! coder%base-4 == previous/outer values of coder%base + ! coder%base-3 == returns final types of any "&" arguments ! coder%base-2 == taints for current procedure ! coder%base-1 == break value -- flags changing types, resolution not complete if /= 0 ! coder%base == argument (on entry) return (on exit) types ! Remaining slots: ! coder%base+index == resolution information according to var or call index ! ================================================================================= - subroutine create_stack_frame(coder,argtype,max_index,init_taints) + + !=============================================================== + ! Create but do not intialise current stack frame + !=============================================================== + subroutine new_stack_frame(coder,max_index) type(code_state),intent(inout):: coder - integer,intent(in):: argtype,max_index,init_taints + integer,intent(in):: max_index coder%stack(coder%top+1)=coder%base - coder%base=coder%top+4 + coder%base=coder%top+5 coder%top=coder%base+max_index if(coder%top>max_code_stack) & call pm_panic('Program too complex (nested calls)') + end subroutine new_stack_frame + + !=============================================================== + ! Create and initialise a stack frame + !=============================================================== + subroutine create_stack_frame(coder,argtype,max_index,init_taints) + type(code_state),intent(inout):: coder + integer,intent(in):: argtype,max_index,init_taints + call new_stack_frame(coder,max_index) call init_stack_frame(coder,coder%base,1,coder%top,argtype,init_taints) end subroutine create_stack_frame !=============================================================== ! (Re)initialise current stack frame + ! Only slots first..last are initialised (as are control slots) !=============================================================== subroutine init_stack_frame(coder,base,first,last,argtype,init_taints) type(code_state),intent(inout):: coder integer,intent(in):: base,first,last,argtype,init_taints integer:: i + coder%stack(base-3)=-1 coder%stack(base-2)=init_taints coder%stack(base-1)=0 coder%stack(base)=argtype @@ -2979,124 +3100,124 @@ end subroutine init_stack_frame !=============================================================== subroutine pop_stack_frame(coder) type(code_state),intent(inout):: coder - coder%top=coder%base-4 - coder%base=coder%stack(coder%base-3) + coder%top=coder%base-5 + coder%base=coder%stack(coder%base-4) if(coder%base==0) call pm_panic('xxx') end subroutine pop_stack_frame - !=============================================================== - ! Perform poly type conversion from typ2 to typ1 if possible - ! Return converted type or -1 on failure - !=============================================================== - function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) - type(code_state),intent(inout):: coder - integer,intent(in):: typ1,typ2 - logical,intent(in):: conv_poly - integer:: typ3 - type(pm_ptr):: tv1,tv2 - if(typ1<=0) return - typ3=-1 - tv1=pm_type_vect(coder%context,typ1) - tv2=pm_type_vect(coder%context,typ2) - if(pm_tv_kind(tv1)==pm_type_is_poly) then - if(pm_tv_kind(tv2)==pm_type_is_poly) then - if(conv_poly.and.pm_type_includes(coder%context,& - pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_type_incl_type)) then - if(add_poly_to_poly(coder,typ1,typ2)) then - coder%types_finished=.false. - endif - typ3=typ1 - endif - else - if(pm_type_includes(coder%context,& - pm_tv_arg(tv1,1),typ2,& - pm_type_incl_type)) then - if(add_type_to_poly(coder,typ1,typ2)) then - coder%types_finished=.false. - endif - typ3=typ1 - endif - endif - endif - end function convert_poly - - !============================================================== - ! Return the working set for a given poly type - ! Returns a set type - !============================================================== - function check_poly(coder,poly_type) result(ptr) - type(code_state),intent(inout):: coder - integer,intent(in):: poly_type - type(pm_ptr):: ptr - integer(pm_ln):: j - integer,dimension(1):: key - key(1)=poly_type - j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) - if(j==0) then - ptr=pm_null_obj - else - ptr=pm_dict_val(coder%context,coder%poly_cache,j) - endif - end function check_poly - - !======================================================= - ! Add a type to the working set for a given poly type - ! Return whether working set has changed - !====================================================== - function add_type_to_poly(coder,poly_type,mtyp) result(changed) - type(code_state),intent(inout):: coder - integer,intent(in):: poly_type,mtyp - logical:: changed - integer,dimension(1):: key - integer(pm_ln):: j - type(pm_ptr):: v - key(1)=poly_type - j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) - if(j==0) then - coder%temp=pm_set_new(coder%context,32_pm_ln) - j=pm_idict_add(coder%context,& - coder%poly_cache,& - key,1,coder%temp) - key(1)=mtyp - j=pm_iset_add(coder%context,& - coder%temp,key,1) - changed=.true. - else - key(1)=mtyp - v=pm_dict_val(coder%context,coder%poly_cache,j) - j=pm_iset_add(coder%context,v,key,1,changed) - endif - end function add_type_to_poly - - !======================================================= - ! Add all types in poly_type2 to the working set for - ! poly type poly_type - ! Return whether working set has changed - !====================================================== - function add_poly_to_poly(coder,poly_type,poly_type2) result(changed) - type(code_state),intent(inout):: coder - integer,intent(in):: poly_type,poly_type2 - logical:: changed - type(pm_ptr):: typeset1,typeset2,type_entry - integer(pm_ln):: i,j,n - integer,dimension(1):: key - changed=.false. - typeset2=check_poly(coder,poly_type2) - if(pm_fast_isnull(typeset2)) return - typeset1=check_poly(coder,poly_type) - if(pm_fast_isnull(typeset1)) then - coder%temp=pm_set_new(coder%context,32_pm_ln) - key(1)=poly_type - j=pm_idict_add(coder%context,& - coder%poly_cache,& - key,1,coder%temp) - typeset1=coder%temp - endif - call pm_set_merge(coder%context,typeset1,typeset2,changed) - contains - include 'fisnull.inc' - end function add_poly_to_poly +!!$ !=============================================================== +!!$ ! Perform poly type conversion from typ2 to typ1 if possible +!!$ ! Return converted type or -1 on failure +!!$ !=============================================================== +!!$ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: typ1,typ2 +!!$ logical,intent(in):: conv_poly +!!$ integer:: typ3 +!!$ type(pm_ptr):: tv1,tv2 +!!$ if(typ1<=0) return +!!$ typ3=-1 +!!$ tv1=pm_type_vect(coder%context,typ1) +!!$ tv2=pm_type_vect(coder%context,typ2) +!!$ if(pm_tv_kind(tv1)==pm_type_is_poly) then +!!$ if(pm_tv_kind(tv2)==pm_type_is_poly) then +!!$ if(conv_poly.and.pm_type_includes(coder%context,& +!!$ pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& +!!$ pm_type_incl_type)) then +!!$ if(add_poly_to_poly(coder,typ1,typ2)) then +!!$ coder%types_finished=.false. +!!$ endif +!!$ typ3=typ1 +!!$ endif +!!$ else +!!$ if(pm_type_includes(coder%context,& +!!$ pm_tv_arg(tv1,1),typ2,& +!!$ pm_type_incl_type)) then +!!$ if(add_type_to_poly(coder,typ1,typ2)) then +!!$ coder%types_finished=.false. +!!$ endif +!!$ typ3=typ1 +!!$ endif +!!$ endif +!!$ endif +!!$ end function convert_poly +!!$ +!!$ !============================================================== +!!$ ! Return the working set for a given poly type +!!$ ! Returns a set type +!!$ !============================================================== +!!$ function check_poly(coder,poly_type) result(ptr) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: poly_type +!!$ type(pm_ptr):: ptr +!!$ integer(pm_ln):: j +!!$ integer,dimension(1):: key +!!$ key(1)=poly_type +!!$ j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) +!!$ if(j==0) then +!!$ ptr=pm_null_obj +!!$ else +!!$ ptr=pm_dict_val(coder%context,coder%poly_cache,j) +!!$ endif +!!$ end function check_poly +!!$ +!!$ !======================================================= +!!$ ! Add a type to the working set for a given poly type +!!$ ! Return whether working set has changed +!!$ !====================================================== +!!$ function add_type_to_poly(coder,poly_type,mtyp) result(changed) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: poly_type,mtyp +!!$ logical:: changed +!!$ integer,dimension(1):: key +!!$ integer(pm_ln):: j +!!$ type(pm_ptr):: v +!!$ key(1)=poly_type +!!$ j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) +!!$ if(j==0) then +!!$ coder%temp=pm_set_new(coder%context,32_pm_ln) +!!$ j=pm_idict_add(coder%context,& +!!$ coder%poly_cache,& +!!$ key,1,coder%temp) +!!$ key(1)=mtyp +!!$ j=pm_iset_add(coder%context,& +!!$ coder%temp,key,1) +!!$ changed=.true. +!!$ else +!!$ key(1)=mtyp +!!$ v=pm_dict_val(coder%context,coder%poly_cache,j) +!!$ j=pm_iset_add(coder%context,v,key,1,changed) +!!$ endif +!!$ end function add_type_to_poly +!!$ +!!$ !======================================================= +!!$ ! Add all types in poly_type2 to the working set for +!!$ ! poly type poly_type +!!$ ! Return whether working set has changed +!!$ !====================================================== +!!$ function add_poly_to_poly(coder,poly_type,poly_type2) result(changed) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: poly_type,poly_type2 +!!$ logical:: changed +!!$ type(pm_ptr):: typeset1,typeset2,type_entry +!!$ integer(pm_ln):: i,j,n +!!$ integer,dimension(1):: key +!!$ changed=.false. +!!$ typeset2=check_poly(coder,poly_type2) +!!$ if(pm_fast_isnull(typeset2)) return +!!$ typeset1=check_poly(coder,poly_type) +!!$ if(pm_fast_isnull(typeset1)) then +!!$ coder%temp=pm_set_new(coder%context,32_pm_ln) +!!$ key(1)=poly_type +!!$ j=pm_idict_add(coder%context,& +!!$ coder%poly_cache,& +!!$ key,1,coder%temp) +!!$ typeset1=coder%temp +!!$ endif +!!$ call pm_set_merge(coder%context,typeset1,typeset2,changed) +!!$ contains +!!$ include 'fisnull.inc' +!!$ end function add_poly_to_poly !================================================= ! Get currently resolved type (&mode) for argument @@ -3193,6 +3314,7 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) integer,intent(in):: typ logical,intent(in),optional:: no_init integer:: typ0,typ2 + logical:: ok,added typ0=get_var_type(coder,cnode,var,init=.true.) typ2=typ0 if(typ/=typ0) then @@ -3207,22 +3329,27 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) 'Variable/constant is not intialised in '//& ' all branches of a conditional statment:',& cnode_get(var,var_name)) + typ2=error_type else - call cnode_error(coder,var,'Value does not have consistent type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - 'First: '//trim(pm_type_as_string(coder%context,typ0))) - call more_error(coder%context,& - 'Then: '//trim(pm_type_as_string(coder%context,typ))) - if(present(no_init)) then - call cnode_error(coder,cnode,& - 'Above type is inconsistent between branches of this statement') - else - call cnode_error(coder,cnode,'Type inconsistency occurs here') + typ2=pm_type_combine(coder%context,typ0,typ,ok,added) + if(.not.ok) then + call cnode_error(coder,var,'Value does not have consistent type:',& + cnode_get(var,var_name)) + call more_error(coder%context,& + 'First: '//trim(pm_type_as_string(coder%context,typ0))) + call more_error(coder%context,& + 'Then: '//trim(pm_type_as_string(coder%context,typ))) + if(present(no_init)) then + call cnode_error(coder,cnode,& + 'Above type is inconsistent between branches of this statement') + else + call cnode_error(coder,cnode,'Type inconsistency occurs here') + endif + typ2=error_type endif endif endif - typ2=error_type + endif endif call set_var_type(coder,var,typ2) @@ -3239,7 +3366,7 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) integer,intent(inout):: tno2 logical,intent(in):: isvar integer:: k - logical:: ok + logical:: ok,converted_to_poly integer:: tno3,base,key(1) k=0 if(tno1<0.or.tno2<=0) then @@ -3252,17 +3379,9 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) if(tno3>=0) tno2=tno3 ok=pm_type_includes(coder%context,tno1,tno2,pm_type_incl_val) if(.not.ok) then - tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.true.,.false.) - if(tno3==undefined) then - base=coder%wtop - tno3=convert_poly(coder,tno1,tno2,.true.) - if(tno3/=-1) then - k=tno3 - tno2=tno3 - ok=.true. - endif - coder%wtop=base - else + tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.true.,.true.,converted_to_poly) + if(converted_to_poly) k=tno3 + if(tno3>=0) then tno2=tno3 ok=.true. endif diff --git a/src/types.f90 b/src/types.f90 index 649e635..ded2f73 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -347,9 +347,9 @@ function pm_new_type(context,arr,val) result(tno) do k=3,size(arr) flags=pm_type_flags(context,arr(k)) tflags=ior(tflags,flags) - nleaves=max(nleaves+flags/pm_type_leaves,pm_type_max_leaves) + nleaves=min(nleaves+flags/pm_type_leaves,pm_type_max_leaves) enddo - arr(1)=ior(arr(1),iand(tflags,& + arr(1)=ior(iand(arr(1),pm_type_leaves-1),iand(tflags,& iand(pm_type_leaves-1,not(pm_type_kind_mask+pm_type_flags_untainting))))+& nleaves*pm_type_leaves k=pm_ivect_lookup(context,context%tcache, & @@ -472,19 +472,42 @@ function pm_type_union(context,a,b) result(tno) end function pm_type_union !========================================== - ! Create new polymorphic type: @etype + ! Create new polymorphic type: *etype !========================================== function pm_new_poly_type(context,etyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp integer:: tno - integer,dimension(3):: args + integer,dimension(2):: args args(1)=pm_type_new_poly - args(2)=0 - args(3)=etyp + args(2)=etyp tno=pm_new_basic_type(context,args) end function pm_new_poly_type + + !================================================ + ! Create new polymorphic value type: *etype=vtyp + ! - assumes that vtyp conforms to etyp + !================================================ + function pm_new_poly_val_type(context,etyp,vtyp) result(tno) + type(pm_context),pointer:: context + integer,intent(in):: etyp,vtyp + integer:: tno + integer,dimension(3):: args + integer:: recur + write(*,*) 'New poly val: ',trim(pm_type_as_string(context,etyp)),' : ',& + trim(pm_type_as_string(context,vtyp)) + args(1)=pm_type_new_poly + args(2)=etyp + recur=-1 + args(3)=pm_type_identify_recursive(context,vtyp,etyp,recur) + if(recur>=0) then + call pm_type_set_recursive_ref(context,recur,args(3)) + endif + tno=pm_new_basic_type(context,args) + end function pm_new_poly_val_type + + !========================================== ! Create new type-value type: !========================================== @@ -723,11 +746,15 @@ function pm_type_flags(context,tno) result(flags) do while(iand(flags,pm_type_kind_mask)==pm_type_is_user) tv=pm_dict_val(context,context%tcache,int(tno2,pm_ln)) tno2=tv%offset - if(tno2/=0) then + if(tno2==tno) then + flags=pm_type_is_recursive + exit + elseif(tno2/=0) then tv=pm_type_vect(context,tno2) flags=pm_tv_flags(tv) else flags=pm_type_has_generic + exit endif enddo endif @@ -1578,7 +1605,14 @@ recursive function pm_test_type_includes(context,supertype,subtype,& mode,params,base,user,ubase) endif endif - case(pm_type_is_type,pm_type_is_poly) + case(pm_type_is_poly) + if(uk/=tk) then + ok=.false. + else + ok=pm_test_type_includes(context,pm_tv_name(t),pm_tv_name(u),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) + endif + case(pm_type_is_type) if(uk/=tk) then ok=.false. else @@ -2262,11 +2296,14 @@ end function test_gated_type !=============================================== ! Perform enveloping conversions if possible ! Returns -1 if not possible + ! Set converted_to_poly if a poly conversion has + ! been performed and the value needs boxing !============================================== - function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(ctyp) + function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly,converted_to_poly) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp logical,intent(in):: doliteral,doproc,dopoly + logical,intent(out),optional:: converted_to_poly integer:: ctyp integer:: tk,ptyp,atyp,pmode,amode type(pm_ptr):: tv @@ -2276,6 +2313,7 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c if(partyp<0.or.argtyp<0) then return endif + if(present(converted_to_poly)) converted_to_poly=.false. ptyp=partyp atyp=pm_type_strip_mode(context,argtyp,amode) tk=pm_type_kind(context,ptyp) @@ -2303,7 +2341,7 @@ function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly) result(c ctyp=pm_proc_type_convert(context,ptyp,atyp) endif if(ctyp<0.and.dopoly.and.tk==pm_type_is_poly) then - ctyp=pm_poly_type_convert(context,ptyp,atyp) + ctyp=pm_poly_type_convert(context,ptyp,atyp,converted_to_poly) endif ctyp=pm_type_add_mode(context,ctyp,amode) !write(*,*) 'To:',trim(pm_type_as_string(context,ctyp)) @@ -2356,21 +2394,32 @@ function pm_type_strip_literal(context,typ) result(ctyp) end function pm_type_strip_literal !================================================================ - ! Autoconversion to broader poly type + ! Autoconversion to broader poly type or from + ! monomorphic to polymorphic type ! Returns -1 if not possible !================================================================ - function pm_poly_type_convert(context,partyp,argtyp) result(ctyp) + function pm_poly_type_convert(context,partyp,argtyp,converted_to_poly) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp + logical,intent(out),optional:: converted_to_poly integer:: ctyp type(pm_ptr):: tv1,tv2 ctyp=-1 tv1=pm_type_vect(context,partyp) tv2=pm_type_vect(context,argtyp) - if(pm_tv_kind(tv1)==pm_type_is_poly.and.pm_tv_kind(tv2)==pm_type_is_poly) then - if(pm_type_includes(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_type_incl_type)) then - ctyp=partyp + if(present(converted_to_poly)) converted_to_poly=.false. + if(pm_tv_kind(tv1)==pm_type_is_poly) then + if(pm_tv_kind(tv2)==pm_type_is_poly) then + if(pm_type_includes(context,pm_tv_name(tv1),pm_tv_name(tv2),& + pm_type_incl_type)) then + ctyp=partyp + endif + else + if(pm_type_includes(context,pm_tv_name(tv1),argtyp,& + pm_type_incl_type)) then + ctyp=pm_new_poly_val_type(context,pm_tv_name(tv1),argtyp) + if(present(converted_to_poly)) converted_to_poly=.true. + endif endif endif end function pm_poly_type_convert @@ -2581,7 +2630,7 @@ recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=iand(pm_tv_flags(tv),not(pm_type_has_generic)) a(2)=pm_tv_name(tv) if(present(iserr)) then do i=1,n @@ -2626,7 +2675,7 @@ recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=iand(pm_tv_flags(tv),not(pm_type_has_fix)) a(2)=pm_tv_name(tv) do i=1,n a(i+2)=pm_type_for_var(context,pm_tv_arg(tv,i),new_mode) @@ -2646,22 +2695,31 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) integer:: typ type(pm_ptr):: tv,tv2 integer:: tk,tk2 + + write(*,*) 'combine types: ',trim(pm_type_as_string(context,tno)),' with ',& + trim(pm_type_as_string(context,tno2)) ok=.true. added=.false. - if(tno<0) then + if(tno<=0) then typ=tno2 return endif typ=tno - if(tno2<0.or.tno==tno2) return + if(tno2<=0.or.tno==tno2) return tv=pm_type_vect(context,tno) tv2=pm_type_vect(context,tno2) + write(*,*) 'xxx',iand(pm_tv_flags(tv),pm_type_has_poly)==0,& + iand(pm_tv_flags(tv2),pm_type_has_poly)==0 + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0.or.& iand(pm_tv_flags(tv2),pm_type_has_poly)==0) then ok=.false. return endif + + write(*,*) 'Here' + tk=pm_tv_kind(tv) tk2=pm_tv_kind(tv2) select case(tk2) @@ -2676,6 +2734,8 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) typ=pm_type_combine(context,tno,pm_user_type_body(context,tno2),ok,added) return end select + + write(*,*) 'there' select case(tk) case(pm_type_is_par_kind) @@ -2691,12 +2751,15 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) endif call remake(pm_tv_numargs(tv)) case(pm_type_is_poly) + write(*,*) 'ere' if(tk/=tk2.or.pm_tv_name(tv)/=pm_tv_name(tv2)) then + write(*,*) 'Bad poly' ok=.false. typ=-1 return endif call combine_poly(pm_tv_numargs(tv),pm_tv_numargs(tv2)) + write(*,*) 'Combined to: ',trim(pm_type_as_string(context,typ)),ok case default typ=-1 ok=.false. @@ -2707,7 +2770,7 @@ recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=pm_tv_flags(tv) a(2)=pm_tv_name(tv) do i=1,n a(i+2)=pm_type_combine(context,pm_tv_arg(tv,i),pm_tv_arg(tv2,i),ok,added) @@ -2723,8 +2786,10 @@ recursive subroutine combine_poly(n,n2) integer,intent(in):: n,n2 integer,dimension(n+n2+2):: a logical,dimension(n):: mask - integer:: i,j,m,recur - a(1)=tk + integer:: i,j,m,recur,typ2 + logical:: elem_added,elem_ok + + a(1)=pm_type_new_poly a(2)=pm_tv_name(tv) do j=1,n a(2+j)=pm_tv_arg(tv,j) @@ -2736,8 +2801,9 @@ recursive subroutine combine_poly(n,n2) outer:do i=1,n2 do j=1,n if(.not.mask(j)) then - if(pm_type_includes(context,a(2+j),& - pm_tv_arg(tv2,i),pm_type_incl_val)) then + typ2=pm_type_combine(context,a(2+j),pm_tv_arg(tv2,i),elem_ok,elem_added) + if(elem_ok) then + added=added.or.elem_added mask(j)=.true. cycle outer endif @@ -2748,6 +2814,8 @@ recursive subroutine combine_poly(n,n2) a(m)=pm_tv_arg(tv2,i) enddo outer + write(*,*) 'combine poly',m,added + ! Nothing added so just return if(.not.added) then typ=tno @@ -2789,7 +2857,7 @@ function pm_type_new_recursive_ref(context) result(tno) end function pm_type_new_recursive_ref !============================================== - ! Make recursive referenc point to given type + ! Make recursive reference point to given type !============================================== subroutine pm_type_set_recursive_ref(context,typ,tno) type(pm_context),pointer:: context @@ -2828,7 +2896,7 @@ recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=pm_tv_flags(tv) a(2)=pm_tv_name(tv) do i=1,n a(i+2)=pm_type_move_recursive(context,pm_tv_arg(tv,i),recur) @@ -2837,11 +2905,55 @@ recursive subroutine remake(n) end subroutine remake end function pm_type_move_recursive + + !================================================================ + ! Create a new type with with all fix values converted + ! to base type and mode changed to new_mode + !================================================================ + recursive function pm_type_identify_recursive(context,tno,etyp,recur) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno,etyp + integer,intent(inout):: recur + integer:: typ + type(pm_ptr):: tv + integer:: tk + typ=tno + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0) return + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,& + pm_type_identify_recursive(context,pm_tv_arg(tv,1),etyp,recur),pm_tv_name(tv)) + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) + call remake(pm_tv_numargs(tv)) + case(pm_type_is_poly) + if(pm_tv_name(tv)==etyp) then + if(recur<0) then + recur=pm_type_new_recursive_ref(context) + endif + typ=recur + endif + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=pm_tv_flags(tv) + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_identify_recursive(context,pm_tv_arg(tv,i),etyp,recur) + enddo + typ=pm_new_type(context,a) + end subroutine remake + end function pm_type_identify_recursive + !================================================================ ! Strip all poly types in a given types down to just the constaint ! with no membership information !================================================================ - recursive function pm_type_poly_base(context,tno) result(typ) + recursive function pm_type_strip_poly(context,tno) result(typ) type(pm_context),pointer:: context integer,intent(in):: tno integer:: typ @@ -2854,7 +2966,7 @@ recursive function pm_type_poly_base(context,tno) result(typ) select case(tk) case(pm_type_is_par_kind) typ=pm_type_add_mode(context,& - pm_type_poly_base(context,pm_tv_arg(tv,1)),pm_tv_name(tv)) + pm_type_strip_poly(context,pm_tv_arg(tv,1)),pm_tv_name(tv)) case(pm_type_is_user) typ=pm_user_type_body(context,tno) case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) @@ -2869,14 +2981,14 @@ recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=pm_tv_flags(tv) a(2)=pm_tv_name(tv) do i=1,n - a(i+2)=pm_type_poly_base(context,pm_tv_arg(tv,i)) + a(i+2)=pm_type_strip_poly(context,pm_tv_arg(tv,i)) enddo typ=pm_new_type(context,a) end subroutine remake - end function pm_type_poly_base + end function pm_type_strip_poly !================================================================ ! Get vector-of-integer representation of type @@ -3007,6 +3119,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s case(pm_type_is_user,pm_type_is_basic,pm_type_is_category) name=pm_tv_name(tv) if(name<0) then + if(iand(pm_tv_flags(tv),pm_type_is_recursive)/=0) then + if(add_char('{RECUR}')) return + return + endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) return endif @@ -3210,7 +3326,17 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s if(add_char(')')) return case(pm_type_is_poly) if(add_char('*')) return - call bracket(1,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) + call bracket(0,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) + if(pm_opts%show_details) then + if(add_char('{')) return + do i=1,pm_tv_numargs(tv) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) + if(i Date: Wed, 25 Jun 2025 16:49:38 +0100 Subject: [PATCH 28/36] Type inference of recursive types --- src/cnodes.f90 | 13 +- src/codegen.f90 | 18 +- src/infer.f90 | 653 ++++++++++++++++++++++++++++-------------------- src/main.f90 | 6 +- src/opts.f90 | 116 +++++---- src/types.f90 | 43 +++- src/vm.f90 | 26 +- src/wcoder.f90 | 2 + 8 files changed, 524 insertions(+), 353 deletions(-) diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 1a59e85..0c44813 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -447,7 +447,7 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) integer,intent(in):: iunit,n type(pm_ptr),intent(in):: sig_cache,proc_cache integer:: kind,i - type(pm_ptr):: cnode,key + type(pm_ptr):: cnode,key,rvec key=pm_dict_key(context,proc_cache,int(n,pm_ln)) cnode=pm_dict_val(context,proc_cache,int(n,pm_ln)) if(pm_fast_vkind(cnode)==pm_pointer) then @@ -476,8 +476,14 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) write(iunit,'(a)') ' [dcomm]' if(cnode_flags_set(cnode,cnode_args+2,proc_is_file)) & write(iunit,'(a)') ' [file]' - call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& - sig_cache,cnode_arg(cnode,1)) + rvec=cnode_arg(cnode,2) + + if(pm_fast_istiny(rvec)) then + write(iunit,*) '---->',cnode%offset + else + call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& + sig_cache,cnode_arg(cnode,1)) + endif write(iunit,'(a)') '}' case(cnode_is_callsig) write(iunit,'(a)') 'sig{' @@ -525,6 +531,7 @@ subroutine print_sig(context,iunit,sig_cache,proc_cache,n) contains include 'fesize.inc' include 'fvkind.inc' + include 'fistiny.inc' end subroutine print_sig subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) diff --git a/src/codegen.f90 b/src/codegen.f90 index 9dfa972..ef8b382 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -164,14 +164,17 @@ module pm_codegen integer:: block_entry,block_base ! Flags indicating type inference not complete - logical:: types_finished,redo_calls,incomplete,first_pass,types_changed + logical:: incomplete,types_changed ! Type inference - depth of nested loops integer:: loop_depth - ! Taints + ! Type Inference - Taints integer:: taints,proc_taints + ! Type inference - arg & return types + integer:: atype,new_atype,rtype + ! Type inference base of current proc record integer:: base @@ -484,7 +487,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call get_lex_scope(coder,node) if(sym/=sym_until) call code_val(coder,coder%var(coder%mask)) call make_sp_call(coder,cblock,node,& - sym,merge(4,5,sym==sym_until),0) + sym,merge(3,4,sym==sym_until),0) call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_do_stmt) @@ -2037,7 +2040,6 @@ subroutine update_change_lists(coder,var,modify) lex_scope=coder%lex_scope lex_scope_of_var=cnode_get_num(var,var_lex_scope) do while(lex_scope_of_varcnode_num_kinds) then write(iunit,*) spaces(1:depth*2),'Bad kind' return diff --git a/src/infer.f90 b/src/infer.f90 index 278971d..e5407f5 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -60,13 +60,6 @@ module pm_infer integer,parameter:: undefined=-1 integer,parameter:: error_type=-2 - ! Parallel modes - integer,parameter:: par_mode_outer=1 - integer,parameter:: par_mode_multi_node=2 - integer,parameter:: par_mode_single_node=3 - integer,parameter:: par_mode_conc=4 - integer,parameter:: par_mode_inner=5 - private:: get_var_type,get_arg_type contains @@ -89,46 +82,42 @@ subroutine inf_prog(coder) coder%flag_recursion=.false. coder%trace_depth=0 - coder%poly_cache=pm_dict_new(coder%context,32_pm_ln) - coder%first_pass=.true. + coder%loop_depth=0 - - do - coder%top=1 - coder%wtop=1 - coder%types_finished=.true. - coder%redo_calls=.false. - coder%incomplete=.false. - coder%taints=0 - - coder%proc_cache=pm_dict_new(coder%context,32_pm_ln) - - ! Setup resolution stack block - call create_stack_frame(coder,0,coder%index,0) - - ! Process program code - call inf_cblock(coder,top_code(coder)) - - ! Uncaught break implies infinite recursion - if(coder%incomplete) then - if(coder%num_errors==0) then - call more_error(coder%context,& - 'Error: A procedure in this program has infinite recursion') - coder%flag_recursion=.true. - call inf_cblock(coder,top_code(coder)) - call pm_stop('Program contains infinite recursion') - endif + + coder%top=1 + coder%wtop=1 + coder%incomplete=.false. + coder%taints=0 + + coder%poly_cache=pm_dict_new(coder%context,32_pm_ln) + coder%proc_cache=pm_dict_new(coder%context,32_pm_ln) + + ! Setup resolution stack block + call create_stack_frame(coder,coder%index) + + ! Process program code + call inf_cblock(coder,top_code(coder)) + + ! Uncaught break implies infinite recursion + if(coder%incomplete) then + if(coder%num_errors==0) then + call more_error(coder%context,& + 'Error: A procedure in this program has infinite recursion') + coder%flag_recursion=.true. + call inf_cblock(coder,top_code(coder)) + call pm_stop('Program contains infinite recursion') endif - if(debug_inference) write(*,*) 'FULL PASS FINISHED>',coder%types_finished - if(coder%types_finished) exit - coder%first_pass=.false. - enddo - + endif + ! Create resolved code object call code_int_vec(coder,coder%stack,coder%base,coder%top) call code_num(coder,coder%stack(2)) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) + ! Finalise inference of procs with polymorphic arguments + call inf_poly_procs(coder) + if(debug_inference) write(*,*) 'END OF PROG> vtop=',coder%vtop contains @@ -138,7 +127,7 @@ end subroutine inf_prog ! ==================================================== ! Type-infer procedure - ! Returns signature index as tiny int in on vstack + ! Returns signature index as tiny int on vstack ! ==================================================== function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& keynames,keybase,proc_nkeys,nomatch,only_when,new_atype) result(rtype) @@ -150,24 +139,21 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& logical,intent(out):: nomatch integer,intent(out):: new_atype type(pm_ptr),intent(in):: keynames - type(pm_ptr):: cnode,cac + integer:: rtype integer:: at - integer,dimension(4+proc_nkeys):: key + integer,dimension(4+proc_nkeys):: key,base_key integer,dimension(proc_nkeys):: key_types,junk - integer:: i,j,keysize,nk,tno,vbase - integer(pm_ln):: k - logical:: save_redo_calls,save_incomplete,save_types_changed - integer:: taints,save_taints,save_loop_depth + integer:: i,j,keysize,nk,tno + integer(pm_ln):: k,kk + logical:: save_incomplete,save_types_changed + integer:: taints,save_taints,save_atype,save_new_atype,save_rtype,save_loop_depth integer:: keypartyp,keyargtyp,last_key_index,sp_code - type(pm_ptr):: save_procnode, keys,keytypes - logical:: iscomm,ok,added,change_added + type(pm_ptr):: save_procnode,keys,keytypes + type(pm_ptr):: cached,cac,base_cache,rt_cache,at_cache + logical:: ok,added,change_added,pushed_stack_frame,incomplete + integer,dimension(3):: rtn_cache - taints=0 - vbase=coder%vtop - save_loop_depth=coder%loop_depth - save_types_changed=coder%types_changed - coder%loop_depth=0 new_atype=-1 if(pm_debug_checks) then @@ -187,27 +173,34 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& return endif - iscomm=cnode_flags_set(procnode,pr_flags,proccall_is_comm) - - ! Dictionary entries in coder%proc_cache: - ! Key is proc and argument types - ! Value is tiny int with procedure return type (if >0) - ! or (-1) sp_in_process in process of resolution - ! or (-2) sp_recursive called recursively - ! or (-3) sp_break breaking (or previously broke) out of inference - - ! Is this combination already cached? - key(1)=cnode_get_num(procnode,pr_id) - key(2)=atype ! pm_type_strip_poly(coder%context,atype) + if(coder%top+1+cnode_get_num(procnode,pr_max_index)>max_code_stack) then + call inf_error(coder,callnode,& + 'Very deep (probably recursive) set of nested calls that cannot be processed') + call more_error(coder%context,'Check for recursive procedure calls generating a new type each time') + call more_error(coder%context,& + 'and also for (mutually) recursive calls in the default value expressions for keyword arguments') + call inf_trace(coder) + rtype=error_type + return + endif + + call save_proc_state + coder%loop_depth=0 + coder%atype=atype + coder%proc=procnode + + keysize=2 + pushed_stack_frame=.false. ! Process keyword arguments - they form part of the hash key last_key_index=0 if(proc_nkeys>0) then keys=cnode_get(procnode,pr_keys) last_key_index=keys%data%i(keys%offset+pm_fast_esize(keys)) + pushed_stack_frame=.true. call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) - call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) + call init_stack_frame(coder,coder%base,1,coder%base+last_key_index) call inf_key_args(coder,callnode,procnode,atype,& nkeys,keynames,keybase,key_types,nk,.false.) keysize=keysize+nk @@ -221,16 +214,16 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ! Process when expression nomatch=.false. if(.not.pm_fast_isnull(cnode_get(procnode,pr_when))) then - if(proc_nkeys==0) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) - call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) + if(.not.pushed_stack_frame) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + call init_stack_frame(coder,coder%base,1,coder%base+last_key_index) call inf_arg_types(coder,procnode,atype) call inf_cblock(coder,cnode_get(procnode,pr_when)) + pushed_stack_frame=.true. tno=get_arg_type(coder,callnode,cnode_get(procnode,pr_whenvar)) if(tno==coder%false_fix.or.tno==coder%false_literal) then call pop_stack_frame(coder) nomatch=.true. - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed + call restore_proc_state return elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then call inf_error(coder,procnode,& @@ -242,19 +235,18 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& if(only_when) then call pop_stack_frame(coder) - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed + call restore_proc_state nomatch=.false. return endif - ! Strip poly type membership from keyword argument types and place in lookup key - do i=3,keysize - key(i)=key_types(i-2) ! pm_type_strip_poly(coder%context,key_types(i-2)) - enddo - ! Lookup combination of proc, arg types and all key types ! defined for the procedure (including defaults) + key(1)=cnode_get_num(procnode,pr_id) + key(2)=atype + do i=3,keysize + key(i)=key_types(i-2) + enddo k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) if(debug_inference) then @@ -267,18 +259,29 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ! This combination already cached if(k>0) then - cnode=pm_dict_val(coder%context,coder%proc_cache,k) + cached=pm_dict_val(coder%context,coder%proc_cache,k) if(debug_inference) then write(*,*) 'FOUND',k,'-->',key(1:keysize) - write(*,*) 'CACHED>',k,cnode%data%vkind,cnode%offset,& + write(*,*) 'CACHED>',k,cached%data%vkind,cached%offset,& trim(pm_name_as_string(coder%context,& cnode_get_name(procnode,pr_name))),sp_sig_recursive,sp_sig_in_process endif - ! One of the special in-progress codes - if(pm_fast_istiny(cnode)) then - sp_code=cnode%offset + ! Dictionary entries in coder%proc_cache: + ! Key is proc and argument types + ! Value is vector of ints with procedure return type, & arg types and taints + ! or tiny int + ! (-1) sp_sig_in_process in process of resolution + ! (-2) sp_sig_recursive called recursively + ! (-3) sp_sig_break breaking (or previously broke) out of inference + + taints=0 + incomplete=.false. + + if(pm_fast_istiny(cached)) then + + sp_code=cached%offset if(sp_code==sp_sig_break) then at=atype goto 10 @@ -290,7 +293,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call inf_trace(coder) coder%flag_recursion=.false. endif - coder%incomplete=.true. + incomplete=.true. rtype=error_type elseif(sp_code==sp_sig_in_process) then call pm_dict_set_val(coder%context,coder%proc_cache,& @@ -302,71 +305,45 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call inf_trace(coder) coder%flag_recursion=.false. endif - coder%incomplete=.true. + incomplete=.true. rtype=error_type elseif(sp_code<0) then ! Another special sig rtype=atype call code_num(coder,int(sp_code)) endif - elseif(pm_fast_vkind(cnode)==pm_int) then - ! Return type - rtype=cnode%data%i(cnode%offset) - new_atype=cnode%data%i(cnode%offset+1) - if(debug_inference) write(*,*) 'CACHED RETURN>',rtype + elseif(pm_fast_vkind(cached)==pm_int) then + ! Cached return types + rtype=cached%data%i(cached%offset) + new_atype=cached%data%i(cached%offset+1) + taints=cached%data%i(cached%offset+2) + if(debug_inference) write(*,*) 'CACHED RETURN>',rtype,& + trim(pm_type_as_string(coder%context,rtype)) call code_num(coder,int(k)) else -!!$ ! Combine any polymorphic types in regular or keyword arguments -!!$ at=pm_type_combine(coder%context,cnode_get_num(cnode,4),atype,ok,added) -!!$ if(.not.ok) call pm_panic('Augmenting proc type signature in inf_proc') -!!$ if(added) new_atype=at -!!$ if(proc_nkeys>0) then -!!$ keytypes=cnode_arg(cnode,5) -!!$ do i=1,proc_nkeys -!!$ key_types(i)=pm_type_combine(coder%context,& -!!$ keytypes%data%i(keytypes%offset+i-1),& -!!$ key_types(i),key_added,ok) -!!$ added=added.or.key_added -!!$ enddo -!!$ endif -!!$ -!!$ ! New polymorphic type elements have been added -!!$ if(added) then -!!$ if(proc_nkeys>0) then -!!$ ! Keyword args and associated expressions may have polymorphic types - re-infer -!!$ vbase=coder%vtop -!!$ call init_stack_frame(coder,coder%base,1,coder%base+last_key_index,atype,0) -!!$ call inf_key_args(coder,callnode,procnode,atype,& -!!$ nkeys,keynames,keybase,key_types,nk,.true.) -!!$ endif -!!$ goto 10 -!!$ endif - - ! Not a special code and no new poly types - so have a fully inferred procedure - - ! Pass out taints - taints=cnode_num_arg(cnode,3) - coder%taints=ior(coder%taints,iand(taints,proc_taints)) + ! Not a special code or set of return types - so have a fully inferred procedure + ! Cached return types and taints + taints=cnode_num_arg(cached,3) + rtype=cnode_num_arg(cached,4) + new_atype=cnode_num_arg(cached,5) + ! Push signature call code_num(coder,int(k)) - ! Get return type - cnode=cnode_arg(cnode,2) - rtype=cnode%data%i(cnode%offset) - if(nret==0) rtype=0 if(debug_inference) write(*,*) 'CACHED RTYPE>',rtype + endif - if(proc_nkeys>0) call pop_stack_frame(coder) - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed + if(pushed_stack_frame) call pop_stack_frame(coder) + call restore_proc_state + coder%incomplete=coder%incomplete.or.incomplete + coder%taints=ior(coder%taints,iand(taints,proc_taints)) return endif 10 continue - ! Proc is not (or not yet fully) inferred at=atype @@ -375,8 +352,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call inf_error_with_trace(coder,procnode,& 'Recursion appears to require infinite types') call code_num(coder,0) - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed + call restore_proc_state return endif @@ -388,181 +364,210 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& ! Get ready to type infer k=pm_idict_add(coder%context,coder%proc_cache,& key,keysize,pm_fast_tinyint(coder%context,sp_sig_in_process)) - save_incomplete=coder%incomplete - save_taints=coder%taints - if(proc_nkeys==0.and.pm_fast_isnull(cnode_get(procnode,pr_when))) then + + if(.not.pushed_stack_frame) then call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) endif ! Repeatedly type infer until complete do - if(debug_inference) write(*,*) 'TRY>',key(1),key(2),rtype + if(debug_inference) write(*,*) 'TRY>',key(1),key(2),rtype,trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))) - call init_stack_frame(coder,coder%base,last_key_index+1,coder%top,at,taints) + call init_stack_frame(coder,coder%base,last_key_index+1,coder%top) ! Process code coder%incomplete=.false. coder%taints=taints - save_procnode=coder%proc - coder%proc=procnode + coder%new_atype=-1 + coder%rtype=-1 + call inf_cblock(coder,cnode_get(procnode,pr_cblock)) - coder%proc=save_procnode ! Check procedure record for recursion/completion - cnode=pm_dict_val(coder%context,coder%proc_cache,k) + cached=pm_dict_val(coder%context,coder%proc_cache,k) if(debug_inference) then - write(*,*) 'TRY COMPLETE>',cnode%offset,& - coder%stack(coder%base),coder%stack(coder%base-1),nret + write(*,*) 'TRY COMPLETE>',cached%offset,nret,trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))) endif - if(pm_fast_istiny(cnode)) then - sp_code=cnode%offset + if(pm_fast_istiny(cached)) then + sp_code=cached%offset if(sp_code==sp_sig_in_process) then ! Not recursively called - rtype=coder%stack(coder%base) - new_atype=coder%stack(coder%base-3) - if(nret==0) rtype=0 + rtype=coder%rtype + new_atype=coder%new_atype + taints=coder%taints if(debug_inference) write(*,*) 'NOT RECURSIVE>',rtype,coder%incomplete exit else if(sp_code<=sp_sig_recursive) then ! Recursively called - if(nret==0) coder%stack(coder%base)=0 - - if(coder%stack(coder%base)<0) then + if(nret>0.and.coder%rtype<0) then ! No resolved type yet ! flag cache entry ! and break out call pop_stack_frame(coder) sp_code=sp_sig_break call pm_dict_set_val(coder%context,& - coder%proc_cache,k,cnode) + coder%proc_cache,k,cached) + call restore_proc_state coder%incomplete=.true. - coder%taints=save_taints rtype=error_type + new_atype=-1 if(debug_inference) write(*,*) 'NOT RESOLVED>' - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed return endif - ! Flag procedure as recursive - coder%taints=ior(coder%taints,proc_is_recursive) - - ! Cache resolved return type - cnode=pm_fast_newnc(coder%context,pm_int,2) - cnode%data%i(cnode%offset)=coder%stack(coder%base) - cnode%data%i(cnode%offset+1)=coder%stack(coder%base-3) - call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) + ! Cache resolved return type, new "&" types, taints + rtn_cache(1)=coder%rtype + rtn_cache(2)=coder%new_atype + rtn_cache(3)=ior(coder%taints,proc_is_recursive) + call code_int_vec(coder,rtn_cache,1,3) + call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) + call drop_code(coder) endif else ! Recursive call for which we ! already have a return type - ! check against type just returned + if(debug_inference) write(*,*) 'RT>',rtype,coder%stack(coder%base) - if(pm_fast_vkind(cnode)/=pm_int) call pm_panic('Bad cached proc kind') - - rtype=cnode%data%i(cnode%offset) - new_atype=cnode%data%i(cnode%offset+1) + if(pm_fast_vkind(cached)/=pm_int) call pm_panic('Bad cached proc kind') + + ! Get cached return types, changed "&" arg types and taints + rtype=cached%data%i(cached%offset) + new_atype=cached%data%i(cached%offset+1) + taints=cached%data%i(cached%offset+2) if(debug_inference) write(*,*) 'RECURSIVE WITH TYPE>',& trim(pm_type_as_string(coder%context,rtype)),' FOR ',& trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) ! If returning values or updating "&" arguments, need to check if types have changed - if(nret>0.or.coder%stack(coder%base-3)/=-1) then - added=.false. - if(nret>0) then - rtype=pm_type_combine(coder%context,coder%stack(coder%base),rtype,ok,added) - if(.not.ok) then - call inf_error_with_trace(coder,procnode,& - 'Internal Compiler Error: Procedure return types changed') - endif - endif - if(coder%stack(coder%base-3)/=-1) then - new_atype=pm_type_combine(coder%context,coder%stack(coder%base-3),new_atype,ok,change_added) - if(.not.ok) then - call inf_error_with_trace(coder,procnode,& - 'Internal Compiler Error: Procedure returned "&" arg types changed') - endif - added=added.or.change_added + added=.false. + if(nret>0) then + rtype=pm_type_combine(coder%context,rtype,coder%rtype,ok,added) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Internal Compiler Error: Procedure return types changed: '//& + trim(pm_type_as_string(coder%context,rtype))//'<>'//& + trim(pm_type_as_string(coder%context,cached%data%i(cached%offset)))) endif - if(added) then - cnode=pm_fast_newnc(coder%context,pm_int,2) - cnode%data%i(cnode%offset)=rtype - cnode%data%i(cnode%offset+1)=new_atype - call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) - cycle + endif + if(coder%new_atype/=-1) then + new_atype=pm_type_combine(coder%context,coder%new_atype,new_atype,ok,change_added) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Internal Compiler Error: Procedure returned "&" arg types changed') endif + added=added.or.change_added endif - + if(ior(taints,coder%taints)/=taints) then + added=.true. + taints=ior(taints,coder%taints) + endif + if(added) then + cached%data%i(cached%offset)=rtype + cached%data%i(cached%offset+1)=new_atype + cached%data%i(cached%offset+2)=taints + cycle + endif + ! Flag procedure as recursive - coder%taints=ior(coder%taints,proc_is_recursive) + taints=ior(taints,proc_is_recursive) + + ! Inference is completed exit endif enddo if(debug_inference) then - write(*,*) 'COMPLETED>',coder%stack(coder%base),& - coder%stack(coder%base-1),coder%base + write(*,*) 'COMPLETED>',trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))),' ',k,coder%incomplete endif ! Pass a break out if(coder%incomplete) then call pop_stack_frame(coder) ! clear cache entry - cnode%offset=sp_sig_break + cached%offset=sp_sig_break call pm_dict_set_val(coder%context,& - coder%proc_cache,k,cnode) + coder%proc_cache,k,cached) if(rtype>=0) then call code_num(coder,int(k)) endif - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed + call restore_proc_state return endif - coder%incomplete=save_incomplete - ! Flag recursive calls with taints or keyword args as unfinished taints=iand(coder%taints,proc_taints) + ! Determine a hash key with any polymorphic elements eliminated + added=.false. + base_key(1)=key(1) + do i=2,keysize + base_key(i)=pm_type_strip_poly(coder%context,key(i)) + added=added.or.(base_key(i)/=key(i)) + end do + + ! If the stripped-down hash key is different then need to create a record + ! of this + if(added) then + kk=pm_ivect_lookup(coder%context,coder%poly_cache,base_key,keysize) + if(kk>0) then + base_cache=pm_dict_val(coder%context,coder%poly_cache,kk) + base_cache=cnode_arg(base_cache,2) + do i=2,keysize + base_cache%data%i(base_cache%offset+i-1)=& + pm_type_combine(coder%context,& + base_cache%data%i(base_cache%offset+i-1),key(i),ok,change_added) + enddo + else + call code_val(coder,procnode) + call code_int_vec(coder,key,1,keysize) + rtn_cache(1)=rtype + rtn_cache(2)=new_atype + rtn_cache(3)=taints + call code_int_vec(coder,rtn_cache,1,3) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) + kk=pm_idict_add(coder%context,coder%poly_cache,& + base_key,keysize,top_code(coder)) + call drop_code(coder) + endif + endif + ! Create record of type-annotated code call code_val(coder,procnode) - call code_int_vec(coder,coder%stack,coder%base,coder%top) + if(added) then + call code_num(coder,int(kk)) + else + call code_int_vec(coder,coder%stack,coder%base,coder%top) + endif call code_num(coder,& ior(iand(cnode_get_num(procnode,pr_flags),& proccall_is_comm+proccall_is_inline+proccall_is_no_inline),& coder%taints)) - call code_num(coder,atype) - if(proc_nkeys>0) then - call code_int_vec(coder,key_types,1,nk) - else - call code_null(coder) - endif + call code_num(coder,rtype) + call code_num(coder,new_atype) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,5) - cnode=top_code(coder) - if(debug_inference) then - write(*,*) 'CACHE AS>',key(1:keysize),'>',cnode%offset - endif - k=pm_idict_add(coder%context,coder%proc_cache,& - key,keysize,cnode) + call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) call drop_code(coder) - + call code_num(coder,int(k)) call pop_stack_frame(coder) call cnode_incr_num(procnode,pr_recurse,-1) + call restore_proc_state + ! Pass out taint information coder%proc_taints=iand(coder%taints,proc_taints) coder%taints=ior(save_taints,coder%proc_taints) - coder%loop_depth=save_loop_depth - coder%types_changed=save_types_changed - - if(pm_debug_level>3) then - write(*,*) 'ENDPROCNODE>',key(1),key(2),key(3),key(4),k + if(debug_inference) then + write(*,*) 'ENDPROCNODE>',trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))),k endif contains @@ -572,8 +577,100 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& include 'fvkind.inc' include 'fesize.inc' include 'fisnull.inc' + + subroutine save_proc_state + save_loop_depth=coder%loop_depth + save_types_changed=coder%types_changed + save_incomplete=coder%incomplete + save_taints=coder%taints + save_procnode=coder%proc + save_atype=coder%atype + save_new_atype=coder%new_atype + save_rtype=coder%rtype + end subroutine save_proc_state + + subroutine restore_proc_state + coder%incomplete=save_incomplete + coder%taints=save_taints + coder%proc=save_procnode + coder%atype=save_atype + coder%new_atype=save_new_atype + coder%rtype=save_rtype + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed + end subroutine restore_proc_state + end function inf_proc + !================================================== + ! Resolve all procs with poly arguments listed in + ! poly_cache + !================================================= + subroutine inf_poly_procs(coder) + type(code_state),intent(inout):: coder + integer(pm_ln):: i,k,kk + integer:: j,n,atype,key_type,taints + type(pm_ptr):: cached,procnode,keys,rtns,keyargs,junk + logical:: ok + do i=pm_dict_size(coder%context,coder%poly_cache),1,-1 + ! Details of this proc + cached=pm_dict_val(coder%context,coder%poly_cache,i) + procnode=cnode_arg(cached,1) + keys=cnode_arg(cached,2) + rtns=cnode_arg(cached,3) + atype=keys%data%i(keys%offset+1) + n=pm_fast_esize(keys)-1 + taints=rtns%data%i(rtns%offset+2) + + ! For a recursive proc, make sure that there is an resolved entry in proc_cache + ! to handle any nested recursive calls + if(iand(taints,proc_is_recursive)/=0) then + junk=pm_dict_lookup(coder%context,coder%proc_cache,keys,kk) + if(kk==0) then + call code_val(coder,procnode) + call code_num(coder,int(i)) + call code_num(coder,taints) + call code_num(coder,rtns%data%i(rtns%offset)) + call code_num(coder,rtns%data%i(rtns%offset+1)) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,5) + call pm_dict_set(coder%context,coder%proc_cache,keys,top_code(coder),.true.,.true.,ok) + call drop_code(coder) + endif + endif + + call create_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + + ! Handle keyword arguments + if(n>0) then + call inf_arg_types(coder,procnode,atype) + keyargs=cnode_get(procnode,pr_keycall) + do j=1,n + call inf_cblock(coder,cnode_arg(keyargs,j*2-1+n+n)) + key_type=keys%data%i(keys%offset+j+1) + call set_var_type(coder,cnode_arg(keyargs,j),key_type) + call set_var_type(coder,cnode_arg(keyargs,j+n),key_type) + enddo + end if + + ! Infer main body + coder%atype=atype + coder%incomplete=.false. + call inf_cblock(coder,cnode_get(procnode,pr_cblock)) + + ! Set this entry in poly_cache to inference vector + call code_int_vec(coder,coder%stack,coder%base,coder%top) + call pm_dict_set_val(coder%context,coder%poly_cache,i,top_code(coder)) + call drop_code(coder) + enddo + contains + include 'fesize.inc' + end subroutine inf_poly_procs + + !================================================= + ! Infer conventional (non-keyword) argument types + ! (this routine mainly used as part of inferring + ! keyword argument types) + !================================================= subroutine inf_arg_types(coder,procnode,atype) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: procnode @@ -1401,7 +1498,7 @@ subroutine inf_call(coder,cblock,callnode) trim(pm_type_as_string(coder%context,arg_type(1)))) elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then call check_logical(3,.false.) - coder%stack(coder%base-2)=ior(coder%stack(coder%base-2),proc_is_impure) + coder%taints=ior(coder%taints,proc_is_impure) endif case(sym_fix,sym_literal) tno=arg_type(2) @@ -1421,7 +1518,7 @@ subroutine inf_call(coder,cblock,callnode) pm_new_vect_type(coder%context,arg_type(2)),sym_shared) case(sym_open) if(nargs>0) then - t=pm_type_vect(coder%context,coder%stack(coder%base)) + t=pm_type_vect(coder%context,coder%atype) n=pm_tv_numargs(t) do i=1,nargs slot=get_slot(i) @@ -1443,7 +1540,6 @@ subroutine inf_call(coder,cblock,callnode) coder%stack(slot)=pop_word(coder) endif endif - coder%stack(coder%base)=undefined case(sym_key) ! This is inferred in trav_proc continue @@ -1452,11 +1548,11 @@ subroutine inf_call(coder,cblock,callnode) case(sym_result) call get_arg_types_and_modes call make_type_if_possible(coder,nargs+2) - coder%stack(coder%base)=pop_word(coder) + coder%rtype=pop_word(coder) case(sym_amp) call get_arg_types_and_modes call make_type_if_possible(coder,nargs+2) - coder%stack(coder%base-3)=pop_word(coder) + coder%new_atype=pop_word(coder) case(sym_start_loop) coder%stack(get_slot(2))=pm_logical case(sym_underscore,sym_colon,sym_end_loop) @@ -1472,13 +1568,11 @@ subroutine inf_call(coder,cblock,callnode) call inf_trace(coder) endif case(sym_pm_dump) - if(coder%first_pass) then - if(arg_type_with_mode(1)>0) then - call cnode_error(coder,callnode,'Type inference gives: '//& - trim(pm_type_as_string(coder%context,arg_type_with_mode(1))),warn=.true.) - else - call cnode_error(coder,callnode,'Type inference fails',warn=.true.) - endif + if(arg_type_with_mode(1)>0) then + call cnode_error(coder,callnode,'Type inference gives: '//& + trim(pm_type_as_string(coder%context,arg_type_with_mode(1))),warn=.true.) + else + call cnode_error(coder,callnode,'Type inference fails',warn=.true.) endif case default if(sig>=0.and.sig<=num_sym) then @@ -2412,7 +2506,7 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) coder%supress_errors=.false. endif - if(rt<0) then + if(nret>0.and.rt<0) then if(debug_inference) then write(*,*) 'INCOMPLETE PROC>',coder%vtop,start,coder%incomplete endif @@ -2523,9 +2617,9 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) endif pars=cnode_get_num(proc,pr_ptype) call print_proc_details(coder,proc) - if(m>pm_opts%proc_list.and..not.pm_opts%see_all_procs) then + if(m>pm_opts%proc_list.and..not.pm_opts%show_all_procs) then call more_error(coder%context,& - '... (to see all procedures use -fsee-all-procs)') + '... (to see all procedures use -fshow-all-procs)') exit endif enddo @@ -3042,18 +3136,6 @@ function is_visible(coder,callnode,procnode) result(ok) endif end function is_visible - - ! ================================================================================ - ! Set up type inference frame - ! Five control slots: - ! coder%base-4 == previous/outer values of coder%base - ! coder%base-3 == returns final types of any "&" arguments - ! coder%base-2 == taints for current procedure - ! coder%base-1 == break value -- flags changing types, resolution not complete if /= 0 - ! coder%base == argument (on entry) return (on exit) types - ! Remaining slots: - ! coder%base+index == resolution information according to var or call index - ! ================================================================================= !=============================================================== ! Create but do not intialise current stack frame @@ -3062,7 +3144,7 @@ subroutine new_stack_frame(coder,max_index) type(code_state),intent(inout):: coder integer,intent(in):: max_index coder%stack(coder%top+1)=coder%base - coder%base=coder%top+5 + coder%base=coder%top+1 coder%top=coder%base+max_index if(coder%top>max_code_stack) & call pm_panic('Program too complex (nested calls)') @@ -3071,25 +3153,21 @@ end subroutine new_stack_frame !=============================================================== ! Create and initialise a stack frame !=============================================================== - subroutine create_stack_frame(coder,argtype,max_index,init_taints) + subroutine create_stack_frame(coder,max_index) type(code_state),intent(inout):: coder - integer,intent(in):: argtype,max_index,init_taints + integer,intent(in):: max_index call new_stack_frame(coder,max_index) - call init_stack_frame(coder,coder%base,1,coder%top,argtype,init_taints) + call init_stack_frame(coder,coder%base,1,coder%top) end subroutine create_stack_frame !=============================================================== ! (Re)initialise current stack frame ! Only slots first..last are initialised (as are control slots) !=============================================================== - subroutine init_stack_frame(coder,base,first,last,argtype,init_taints) + subroutine init_stack_frame(coder,base,first,last) type(code_state),intent(inout):: coder - integer,intent(in):: base,first,last,argtype,init_taints + integer,intent(in):: base,first,last integer:: i - coder%stack(base-3)=-1 - coder%stack(base-2)=init_taints - coder%stack(base-1)=0 - coder%stack(base)=argtype do i=base+first,last coder%stack(i)=undefined enddo @@ -3100,8 +3178,8 @@ end subroutine init_stack_frame !=============================================================== subroutine pop_stack_frame(coder) type(code_state),intent(inout):: coder - coder%top=coder%base-5 - coder%base=coder%stack(coder%base-4) + coder%top=coder%base-1 + coder%base=coder%stack(coder%base) if(coder%base==0) call pm_panic('xxx') end subroutine pop_stack_frame @@ -3317,6 +3395,8 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) logical:: ok,added typ0=get_var_type(coder,cnode,var,init=.true.) typ2=typ0 + write(*,*) 'Combining...',trim(pm_type_as_string(coder%context,typ0)),'<>',& + trim(pm_type_as_string(coder%context,typ)) if(typ/=typ0) then if(typ0<=0) then typ2=typ @@ -3346,12 +3426,15 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) call cnode_error(coder,cnode,'Type inconsistency occurs here') endif typ2=error_type + elseif(added) then + coder%types_changed=.true. endif endif endif endif endif + write(*,*) '....to',trim(pm_type_as_string(coder%context,typ2)) call set_var_type(coder,var,typ2) end subroutine combine_var_type @@ -3751,7 +3834,7 @@ end subroutine inf_type_error subroutine inf_trace(coder) type(code_state):: coder type(pm_ptr):: node,modname,tv - integer:: k,top + integer:: k,top,chunk if(.not.pm_main_process) return if(coder%supress_errors) return if(coder%trace_depth<1) return @@ -3774,24 +3857,48 @@ subroutine inf_trace(coder) endif write(*,*) - write(*,*) '-------------CALL TRACE---------------------------' - do k=top,1,-1 - if(k>max_trace_depth) then - write(*,*) 'Procedure call: (call not recorded)' - cycle - endif - node=coder%trace(k) - if((.not.hide(node)).or.& - (.not.pm_opts%hide_sysmod)) then - call print_call_details(coder,node,& - coder%trace_keys(k)) - if(k>1) write(*,*) - endif - enddo - write(*,*) '--------------------------------------------------' + write(*,'(a)') '=====================CALL TRACE===========================' + write(*,*) + if(top>max_trace_depth) then + write(*,*) '------------------------------------------------------' + write(*,*) ' ... UNRECORDED PROCEDURES (TOO MANY NESTED CALLS) ...' + write(*,*) '------------------------------------------------------' + write(*,*) + top=max_trace_depth + endif + if(top<=pm_opts%trace_list.or.pm_opts%show_full_trace) then + do k=top,1,-1 + call trace_entry + enddo + else + chunk=max(2,pm_opts%trace_list/2-1) + do k=top,top-chunk+1,-1 + call trace_entry + enddo + write(*,*) '---------------------------' + write(*,*) ' ... (CALLS SKIPPED) ...' + write(*,*) '---------------------------' + write(*,*) + do k=chunk,1,-1 + call trace_entry + enddo + write(*,*) + write(*,*) ' (Use -fshow-full-trace to show the complete call trace)' + endif + write(*,'(a)') '==========================================================' write(*,*) contains + subroutine trace_entry + node=coder%trace(k) + if((.not.hide(node)).or.& + (.not.pm_opts%hide_sysmod)) then + call print_call_details(coder,node,& + coder%trace_keys(k)) + if(k>1) write(*,*) + endif + end subroutine trace_entry + function hide(node) result(hideit) type(pm_ptr),intent(in):: node logical:: hideit diff --git a/src/main.f90 b/src/main.f90 index 5ca0e75..1894109 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -253,11 +253,7 @@ subroutine run_coder_and_inference(root,visibility,proc_code,proc_cache,poly_cac call run_type_inference(coder) proc_code=coder%vstack(1) proc_cache=coder%proc_cache - if(pm_is_compiling) then - poly_cache=coder%poly_cache - else - poly_cache=pm_null_obj - endif + poly_cache=coder%poly_cache call term_coder(coder) call pm_gc(context,.false.) end subroutine run_coder_and_inference diff --git a/src/opts.f90 b/src/opts.f90 index 644178e..6d9a5ae 100755 --- a/src/opts.f90 +++ b/src/opts.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2021 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -36,10 +36,12 @@ module pm_options logical:: check_stmts logical:: show_elems logical:: show_members - logical:: see_all_procs + logical:: show_all_procs + logical:: show_full_trace logical:: out_debug_files logical:: old_files integer:: proc_list + integer:: trace_list logical:: show_variants logical:: show_details logical:: check_alias @@ -88,8 +90,10 @@ subroutine init_opts(context) pm_opts%check_stmts=.not.pm_is_compiling pm_opts%show_elems=.false. pm_opts%show_members=.false. - pm_opts%see_all_procs=.false. + pm_opts%show_all_procs=.false. + pm_opts%show_full_trace=.false. pm_opts%proc_list=11 + pm_opts%trace_list=11 pm_opts%show_variants=.false. pm_opts%show_details=.false. pm_opts%check_alias=.not.pm_is_compiling @@ -144,14 +148,27 @@ end subroutine init_opts subroutine print_usage if(pm_main_process) then - write(*,*) 'Usage: pm [-f] [-D] [-help] root_module_name_or_filename' write(*,*) - write(*,*) ' -f Language options' - write(*,*) ' --help Longer help message' - write(*,*) ' -D Output compiler debugging information' + if(pm_is_compiling) then + write(*,*) 'Usage: pmc [-f] [-D] [ --help | root_module_name_or_filename ]' + else + write(*,*) 'Usage: pm [-f] [-D] [ --help | -i | root_module_name_or_filename ]' + write(*,*) ' -i Interactive mode' + endif + write(*,*) ' -L Set path to locate PM libraries' + write(*,*) ' -f Language options' + write(*,*) ' -H Terminal output options' + if(pm_is_compiling) then + write(*,*) ' -ftn Fortran language output options' + endif + write(*,*) ' -D Options for debugging the compiler itself' + write(*,*) ' --help Longer help message' endif end subroutine print_usage + + + subroutine usage call print_usage call pm_stop(' ') @@ -167,33 +184,34 @@ subroutine help write(*,*) ' included automatically.' write(*,*) write(*,*) ' CONFIGURATION OPTIONS' - write(*,*) ' -L Look for library files in rather than lib' + write(*,*) ' -L Look for library files in rather than lib' write(*,*) write(*,*) ' LANGUAGE OPTIONS' - write(*,*) ' -fno-inline Do not inline any procedures.' - write(*,*) ' -fno-check Do not run "check" or "test" statements.' - write(*,*) ' -fcheck Run "check" and "test" statements.' - write(*,*) ' -fno-alias-check Do not check for argument aliasing' - write(*,*) ' -falias_check Check for argument aliasing' + write(*,*) ' -fno-inline Do not inline any procedures.' + write(*,*) ' -fno-check Do not run "check" or "test" statements.' + write(*,*) ' -fcheck Run "check" and "test" statements.' + write(*,*) ' -fno-alias-check Do not check for argument aliasing' + write(*,*) ' -falias_check Check for argument aliasing' if(.not.pm_is_compiling) then write(*,*) ' -fprint-immediate' - write(*,*) ' Do not buffer print output by node' + write(*,*) ' Do not buffer print output by node' endif write(*,*) - write(*,*) ' ERROR OR TRACE OUTPUT OPTIONS' - write(*,*) ' -fshow-elems Show structure/record elements in error messages.' - write(*,*) ' -fshow-members Show members of user defined types in error messages' - write(*,*) ' -fshow-variants Show all variants for proc types' - write(*,*) ' -fshow-details Show extra details of types' - write(*,*) ' -fshow-hidden Show hidden procedure parameters' - write(*,*) ' -fsee-all-procs List all alternative procedures in error messages' - write(*,*) ' -fproc-list=n Maximum number of procs to list if see-all-procs not invoked' + write(*,*) ' ERROR AND WARNING MESSAGE OUTPUT OPTIONS' + write(*,*) ' -fshow-elems Show structure/record elements in error messages.' + write(*,*) ' -fshow-members Show members of user defined types in error messages' + write(*,*) ' -fshow-variants Show all variants for proc types' + write(*,*) ' -fshow-all-procs List all alternative procedures in error messages' + write(*,*) ' -fproc-list=n Maximum number of procs to list if show-all-procs not invoked' + write(*,*) ' -fshow-full-trace List all alternative procedures in error messages' + write(*,*) ' -ftrace-list=n Maximum number of calls to list if show-full-trace not invoked' + write(*,*) - write(*,*) ' GENERAL OPTIONS' - write(*,*) ' -N Do not colour-highlight error messages' - write(*,*) ' -H Colour-highlight error messages' - write(*,*) ' -HB Colour-highlight error messages using bright colours' - write(*,*) ' -HS Colour-highlight error messages using standard colours' + write(*,*) ' TERMINAL DISPLAY OPTIONS' + write(*,*) ' -HN Do not colour-highlight error messages' + write(*,*) ' -H Colour-highlight error messages' + write(*,*) ' -HB Colour-highlight error messages using bright colours' + write(*,*) ' -HS Colour-highlight error messages using standard colours' if(pm_is_compiling) then write(*,*) write(*,*) ' OPTIMISER OPTIONS' @@ -234,12 +252,14 @@ subroutine help write(*,*) ' Include various annotation comments (mainly for debugging the compiler)' endif write(*,*) - write(*,*) ' OPTIONS FOR DEBUGGING THE COMPILER' - write(*,*) ' -D Activate all debugging options listed below.' - write(*,*) ' -Dfiles Output files from each compiler stage.' - write(*,*) ' -Dtimings Output time taken by each compilation stage.' - write(*,*) ' -Dsys-mod Output a listing of the system module.' - write(*,*) ' -Dtype-list Output a list of all types used by the system.' + write(*,*) ' OPTIONS FOR DEBUGGING THE COMPILER ITSELF' + write(*,*) ' -Dshow-details Show extra details of types' + write(*,*) ' -Dshow-hidden Show hidden procedure parameters' + write(*,*) ' -D Activate all debugging options listed below.' + write(*,*) ' -Dfiles Output files from each compiler stage.' + write(*,*) ' -Dtimings Output time taken by each compilation stage.' + write(*,*) ' -Dsys-mod Output a listing of the system module.' + write(*,*) ' -Dtype-list Output a list of all types used by the system.' endif call pm_stop(' ') end subroutine help @@ -262,7 +282,7 @@ subroutine pm_get_command_line(context,mname) elseif(arg(1:2)=='-L') then pm_opts%lib_path_set=.true. pm_opts%lib_path=arg(3:) - elseif(arg=='-N') then + elseif(arg=='-HN') then pm_opts%error='Error:' pm_opts%colour=.false. elseif(arg=='-HS') then @@ -277,7 +297,11 @@ subroutine pm_get_command_line(context,mname) pm_opts%error=pm_opts%error_start//'Error: '//pm_error_end pm_opts%colour=.true. elseif(arg(1:2)=='-D') then - if(arg=='-D') then + if(arg=='-Dshow-details') then + pm_opts%show_details=.true. + elseif(arg=='-Dshow-hidden') then + pm_opts%show_hidden=.true. + elseif(arg=='-D') then pm_opts%out_debug_files=.true. pm_opts%out_sysmod=.true. pm_opts%out_typelist=.true. @@ -313,21 +337,21 @@ subroutine pm_get_command_line(context,mname) pm_opts%show_members=.true. elseif(arg=='-fshow-variants') then pm_opts%show_variants=.true. - elseif(arg=='-fshow-details') then - pm_opts%show_details=.true. - elseif(arg=='-fsee-all-procs') then - pm_opts%see_all_procs=.true. + elseif(arg=='-fshow-all-procs') then + pm_opts%show_all_procs=.true. + elseif(arg=='-fshow-full-trace') then + pm_opts%show_full_trace=.true. elseif(arg=='-falias-check') then pm_opts%check_alias=.true. elseif(arg=='-fno-alias-check') then pm_opts%check_alias=.false. elseif(arg=='-fprint-immediate'.and..not.pm_is_compiling) then pm_opts%print_immediate=.true. - elseif(arg=='-fshow-hidden') then - pm_opts%show_hidden=.true. elseif(arg(1:12)=='-fproc-list=') then pm_opts%proc_list=get_num_opt(arg,arg(13:)) - elseif(arg(3:4)=='tn') then + elseif(arg(1:12)=='-ftrace-list=') then + pm_opts%trace_list=get_num_opt(arg,arg(14:)) + elseif(arg(3:4)=='tn'.and.pm_is_compiling) then if(arg=='-ftn-contig') then pm_opts%ftn_contig=.true. elseif(arg=='-ftn-no-contig') then @@ -383,15 +407,15 @@ subroutine pm_get_command_line(context,mname) pm_opts%ftn_name_types=.false. pm_opts%ftn_name_elems=.false. elseif(pm_main_process) then - write(*,*) 'Not a valid fortran name (-ftn-no-name) option:',trim(arg) + write(*,*) 'Not a valid fortran name (-ftn-no-name) option: ',trim(arg) call usage() endif elseif(pm_main_process) then - write(*,*) 'Not a valid fortran output (-ftn) option:',trim(arg) + write(*,*) 'Not a valid fortran output (-ftn) option: ',trim(arg) call usage() endif elseif(pm_main_process) then - write(*,*) 'Not a valid language (-f) option:',trim(arg) + write(*,*) 'Not a valid language (-f) option: ',trim(arg) call usage() endif elseif(arg(1:4)=='-opt') then @@ -400,7 +424,7 @@ subroutine pm_get_command_line(context,mname) elseif(arg=='-opt-no-sched') then pm_opts%schedule=.false. elseif(pm_main_process) then - write(*,*) 'Not a valid optimiser (-opt) option:',trim(arg) + write(*,*) 'Not a valid optimiser (-opt) option: ',trim(arg) call usage() endif elseif(arg=='--help') then diff --git a/src/types.f90 b/src/types.f90 index ded2f73..00200a3 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -501,10 +501,11 @@ function pm_new_poly_val_type(context,etyp,vtyp) result(tno) args(2)=etyp recur=-1 args(3)=pm_type_identify_recursive(context,vtyp,etyp,recur) + tno=pm_new_basic_type(context,args) if(recur>=0) then - call pm_type_set_recursive_ref(context,recur,args(3)) + call pm_type_set_recursive_ref(context,recur,tno) endif - tno=pm_new_basic_type(context,args) + write(*,*) 'Poly type is:',tno end function pm_new_poly_val_type @@ -1447,6 +1448,11 @@ recursive function pm_test_type_includes(context,supertype,subtype,& endif case(pm_type_is_user) if(tk/=pm_type_is_user) then + if(iand(mode,pm_type_incl_extract)/=0) then + if(iand(pm_tv_flags(u),pm_type_is_recursive)/=0) then + goto 10 + endif + endif do i=2,ubase,2 if(user(i)==p.and.user(i+1)==q) then ok=.true. @@ -1543,6 +1549,8 @@ recursive function pm_test_type_includes(context,supertype,subtype,& return end select +10 continue + ! Now do tests that look at 1st type first select case(tk) case(pm_type_is_basic) @@ -1611,6 +1619,16 @@ recursive function pm_test_type_includes(context,supertype,subtype,& else ok=pm_test_type_includes(context,pm_tv_name(t),pm_tv_name(u),& ior(mode,pm_type_incl_nomatch),params,base,user,ubase) + if(pm_tv_numargs(t)>0.and.pm_tv_numargs(u)>0) then + do i=1,pm_tv_numargs(u) + do j=1,pm_tv_numargs(t) + ok=pm_test_type_includes(context,pm_tv_arg(t,j),pm_tv_arg(u,i),& + mode,params,base,user,ubase) + if(ok) exit + enddo + if(.not.ok) exit + end do + endif endif case(pm_type_is_type) if(uk/=tk) then @@ -2707,18 +2725,15 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) endif typ=tno if(tno2<=0.or.tno==tno2) return + if(pm_type_includes(context,tno,tno2,pm_type_incl_val)) return tv=pm_type_vect(context,tno) tv2=pm_type_vect(context,tno2) - write(*,*) 'xxx',iand(pm_tv_flags(tv),pm_type_has_poly)==0,& - iand(pm_tv_flags(tv2),pm_type_has_poly)==0 if(iand(pm_tv_flags(tv),pm_type_has_poly)==0.or.& iand(pm_tv_flags(tv2),pm_type_has_poly)==0) then ok=.false. return endif - - write(*,*) 'Here' tk=pm_tv_kind(tv) tk2=pm_tv_kind(tv2) @@ -2734,8 +2749,6 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) typ=pm_type_combine(context,tno,pm_user_type_body(context,tno2),ok,added) return end select - - write(*,*) 'there' select case(tk) case(pm_type_is_par_kind) @@ -2751,9 +2764,7 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) endif call remake(pm_tv_numargs(tv)) case(pm_type_is_poly) - write(*,*) 'ere' if(tk/=tk2.or.pm_tv_name(tv)/=pm_tv_name(tv2)) then - write(*,*) 'Bad poly' ok=.false. typ=-1 return @@ -2789,6 +2800,8 @@ recursive subroutine combine_poly(n,n2) integer:: i,j,m,recur,typ2 logical:: elem_added,elem_ok + write(*,*) 'combine_poly',trim(pm_type_as_string(context,tno)),'<>',trim(pm_type_as_string(context,tno2)) + a(1)=pm_type_new_poly a(2)=pm_tv_name(tv) do j=1,n @@ -2801,6 +2814,7 @@ recursive subroutine combine_poly(n,n2) outer:do i=1,n2 do j=1,n if(.not.mask(j)) then + write(*,*) 'Combining #',i,j typ2=pm_type_combine(context,a(2+j),pm_tv_arg(tv2,i),elem_ok,elem_added) if(elem_ok) then added=added.or.elem_added @@ -2862,6 +2876,7 @@ end function pm_type_new_recursive_ref subroutine pm_type_set_recursive_ref(context,typ,tno) type(pm_context),pointer:: context integer,intent(in):: typ,tno + write(*,*) 'Set recursive',typ,tno call pm_type_set_val(context,typ,& pm_fast_typeno(context,tno)) contains @@ -2879,6 +2894,7 @@ recursive function pm_type_move_recursive(context,tno,recur) result(typ) type(pm_ptr):: tv integer:: tk typ=tno + if(tno<=0) return tv=pm_type_vect(context,tno) if(iand(pm_tv_flags(tv),pm_type_is_recursive)==0) return tk=pm_tv_kind(tv) @@ -2918,6 +2934,7 @@ recursive function pm_type_identify_recursive(context,tno,etyp,recur) result(typ type(pm_ptr):: tv integer:: tk typ=tno + if(tno<=0) return tv=pm_type_vect(context,tno) if(iand(pm_tv_flags(tv),pm_type_has_poly)==0) return tk=pm_tv_kind(tv) @@ -2933,6 +2950,7 @@ recursive function pm_type_identify_recursive(context,tno,etyp,recur) result(typ recur=pm_type_new_recursive_ref(context) endif typ=recur + write(*,*) 'Made recur',typ endif end select contains @@ -2946,6 +2964,7 @@ recursive subroutine remake(n) a(i+2)=pm_type_identify_recursive(context,pm_tv_arg(tv,i),etyp,recur) enddo typ=pm_new_type(context,a) + write(*,*) 'remade to',typ,a end subroutine remake end function pm_type_identify_recursive @@ -2960,6 +2979,7 @@ recursive function pm_type_strip_poly(context,tno) result(typ) type(pm_ptr):: tv integer:: tk,arr(2) typ=tno + if(tno<=0) return tv=pm_type_vect(context,tno) if(iand(pm_tv_flags(tv),pm_type_has_poly)==0) return tk=pm_tv_kind(tv) @@ -3099,6 +3119,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s logical:: ok,isfix if(n>len(str)-10) return tno=typno +!!$ if(add_char('{'//trim(pm_int_as_string(tno))//'}')) return if(tno==0) then if(add_char('any')) return return @@ -3120,7 +3141,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s name=pm_tv_name(tv) if(name<0) then if(iand(pm_tv_flags(tv),pm_type_is_recursive)/=0) then - if(add_char('{RECUR}')) return + if(add_char('{RECURSE}')) return return endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) diff --git a/src/vm.f90 b/src/vm.f90 index 67d9ca0..b7f98f3 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -321,19 +321,23 @@ recursive function pm_run(context,funcin,stackin,pcin,& endif select case(opcode) - case(op_call,op_comm_call) + case(op_call) ! op_call #proc ve args... + if(.not.ve_is_empty(ve)) then + newfunc=context%funcs%data%ptr(& + context%funcs%offset+opcode2) + if(run_call(newfunc)) goto 999 + endif + case(op_comm_call) ! op_comm_call #proc ve args... - newfunc=context%funcs%data%ptr(& - context%funcs%offset+opcode2) - if(run_call(newfunc)) goto 999 -!!$ case(op_comm_call) -!!$ ve=arg(1)%data%ptr(arg(1)%offset+1) -!!$ esize=ve%data%ln(ve%offset) -!!$ ve=arg(1)%data%ptr(arg(1)%offset) -!!$ newfunc=context%funcs%data%ptr(& -!!$ context%funcs%offset+opcode2) -!!$ if(run_call(newfunc)) goto 999 + if(sync_status(pc,pm_node_running)==pm_node_error) goto 777 + ok=.not.ve_is_empty(ve) + ok=sync_loop_end(ok) + if(ok) then + newfunc=context%funcs%data%ptr(& + context%funcs%offset+opcode2) + if(run_call(newfunc)) goto 999 + endif case(op_skip_empty) ! op_skip_empty #0_or_2 ve &newve ! op_skip_empty #1 ve &newve oldve diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 38f029c..ac24ce6 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -251,6 +251,7 @@ subroutine wcode_procs(wcd) call init_wcode_proc(wcd,proc) pr=cnode_arg(proc,1) rv=cnode_arg(proc,2) + if(pm_fast_istiny(rv)) rv=pm_dict_val(wcd%context,wcd%poly_cache,int(rv%offset,pm_ln)) taints=cnode_arg(proc,3) !keys=cnode_arg(proc,4) if(pm_is_compiling) then @@ -318,6 +319,7 @@ subroutine wcode_procs(wcd) include 'fesize.inc' include 'fisnull.inc' include 'fnewnc.inc' + include 'fistiny.inc' end subroutine wcode_procs !==================================================== From ce636f0a297ba738c1ba1d80b4d2e6ffd5fc8008 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Wed, 2 Jul 2025 17:25:45 +0100 Subject: [PATCH 29/36] Basic assignment --- config/sysdep.f90 | 11 +- lib/sys/pm.pmm | 202 +++++++++++++--------------------- src/array.f90 | 2 +- src/codegen.f90 | 90 +++++++-------- src/infer.f90 | 65 +++++++---- src/parser.f90 | 23 ++-- src/types.f90 | 273 ++++++++++++++++++++++++++++++---------------- src/vmdefs.f90 | 10 +- src/wcoder.f90 | 1 + 9 files changed, 381 insertions(+), 296 deletions(-) diff --git a/config/sysdep.f90 b/config/sysdep.f90 index 7ff39a5..7af88cd 100644 --- a/config/sysdep.f90 +++ b/config/sysdep.f90 @@ -244,7 +244,10 @@ subroutine pm_module_filename(inbuffer,buffer,lib_path_set,lib_path) logical:: ok n=len_trim(inbuffer) if(n>len(pm_file_suffix)) then - if(inbuffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) return + if(inbuffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) then + buffer=inbuffer + return + endif endif if(inbuffer(1:4)=='lib.'.and.lib_path_set) then i=1 @@ -259,7 +262,11 @@ subroutine pm_module_filename(inbuffer,buffer,lib_path_set,lib_path) if(m>=i) then pathlen=m-i+1 tot=pathlen+n-3 - if(tot+len(pm_file_suffix)>len(buffer)) return + if(tot+len_trim(pm_file_suffix)>len(buffer)) then + if(m+2>len(lib_path)) exit + i=m+2 + cycle + endif buffer(1:pathlen)=lib_path(i:m) do i=4,n if(inbuffer(i:i)=='.') then diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index 1a98537..1b292f9 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -588,7 +588,6 @@ type cpx_num is real_num,any_cpx type num is cpx_num // Numeric type conversion -proc convert(x,y)=x proc convert(x:int_num,y:sint)=sint(x) proc convert(x:int_num,y:int)=int(x) proc convert(x:int_num,y:lint)=lint(x) @@ -600,6 +599,7 @@ proc convert(x:int_num,y:sreal)=sreal(x) proc convert(x:int_num,y:real)=real(x) proc convert(x:real_num,y:cpx)=cpx(x) proc convert(x:real_num,y:scpx)=scpx(x) + proc as(x:int_num,y:)=sint(x) proc as(x:int_num,y:)=int(x) proc as(x:int_num,y:)=lint(x) @@ -612,14 +612,6 @@ proc as(x:real_num,y:)=real(x) proc as(x:real_num,y:)=scpx(x) proc as(x:real_num,y:)=cpx(x) -// Auto-conversion on assignment -proc PM__assign(&x:num,y:num) { - _assign_element(&x,convert(y,x)) -} - -proc PM__assign_var(&x:num,y:num) { - PM__assign(&x,convert(y,x)) -} // Mixed arithmatic type _to_sint is int @@ -1103,7 +1095,8 @@ type step_base is real_num // Range types type range(t:range_base,hi:range_base) is rec {_lo:t,_hi:hi,_n:int} proc ..(x:range_base,y:range_base)=rec range { -_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) + _lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc ..(x:literal(int),y:literal(int))=literal(rec range{_lo=xx,_hi=yy,_n=max(0,yy-xx)+1}) where xx=fix(x),yy=fix(y) proc low(x:range)=x._lo proc high(x:range)=x._hi proc step(x:range)=convert(1,x._lo) @@ -1137,6 +1130,7 @@ proc real(x:range)=rec range { } proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:[int])=x._lo+convert(y.1,x._lo) proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st proc element(x:range(any_int),y:null)=x @@ -1603,30 +1597,59 @@ proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) // *************************************************** proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) <> { - PM__for shape { - here_in_tile=PM__generate(shape,shape) + PM__for size(shape) { + let here_in_tile=PM__generate(shape,size(shape)) PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { var inouts=PM__import(PM__inouts) - var inout_a=PM__get_elem(PM__inout_a,here_in_tile) + var inout_a_i=PM__import(PM__inout_a) + var inout_a=PM__get_elem(inout_a_i,here_in_tile) PM__block_proc.'(&inouts, PM__import(PM__ins), &inout_a, - PM__get_elem(PM__in_a,here_in_tile), - PM__get_elem(PM__star_a,here_in_tile) <>) + PM__get_elem(PM__import(PM__in_a),here_in_tile), + PM__get_elem(PM__import(PM__star_a),here_in_tile) <>) PM__export(&PM__inouts,inouts) - PM__set_elem(&PM__inout_a,inout_a,here_in_tile) + PM__set_elem(&inout_a_i,inout_a,here_in_tile) } } } +proc PM__foreach_stmt'(&PM__inout_a,PM__in_a,shape:extent(1)) yield(&any,any) <> { + var index=low(shape.1) + while index<=high(shape.1) { + var inout_a=PM__get_elem(PM__inout_a,[index]) + PM__block_proc.'(&PM__inouts, + PM__ins, + &inout_a, + PM__get_elem(PM__in_a,[index]) <>) + PM__set_elem(&PM__inout_a,inout_a,[index]) + index=index+1 + } +} + +proc PM__foreach_stmt'(&PM__inout_a,PM__in_a,shape:extent(2)) yield(&any,any) <> { + var index2=low(shape.2) + while index2<=high(shape.2) { + var index1=low(shape.1) + while index1<=high(shape.1) { + var inout_a=PM__get_elem(PM__inout_a,[index1,index2]) + PM__block_proc.'(&PM__inouts, + PM__ins, + &inout_a, + PM__get_elem(PM__in_a,[index1,index2]) <>) + PM__set_elem(&PM__inout_a,inout_a,[index1,index2]) + index1=index1+1 + } + index2=index2+1 + } +} + proc PM__par_stmt'(num) yield() <> { yield() } proc PM__check_task'(num)=true proc PM__chan_stmt'() yield() { yield() } proc PM__over_stmt'(x) yield() { yield() } -proc #'(x)=x - proc PM__check_iter(x){} proc PM__check_iter_amp(x){} proc PM__check_iter_star(x){} @@ -1634,19 +1657,21 @@ proc PM__check_iter(x,y){} proc PM__check_iter_amp(x,y){} proc PM__check_iter_star(x,y){} -proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):h) -proc PM__get_elem(x,h)=h +proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):PM__get_elem(x.{i},h)) +proc PM__get_elem(x,h)=element(x,h) proc PM__set_elem(&x,y,h) {} -proc PM__export(&x,y) {} -proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(element_at_index(x,i))) +proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(x.{i})) PM__intrinsic PM__import(x:any)->(=x) : "import_val" +proc PM__export(&x:PM__list,y:PM__list) {PM__each_index i in num_elements(x){PM__export(&x.{i},y.{i})}} +PM__intrinsic PM__export(&x:any,y:any): "export" -proc PM__generate(x,n)=old_dumpit(_elts(x,1,n)) +proc PM__generate(x,n)=_elts(x,1,n) PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" proc _n(x:int)=x -proc _elts(x:int,siz,tot)=old_dumpit(_iota(siz,0,x,1,tot)) +proc _elts(x:int,siz,tot)=_iota(siz,0,x,1,tot) +proc _elts(x:range(int),siz,tot)=_iota(siz,0,size(x),1,tot) proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) @@ -1670,15 +1695,10 @@ proc match_switch_case(x:literal,y:literal)=x==y proc match_switch_case(x:fix(any),y:fix(any))=x==y proc match_switch_case(x,y)=x==y proc match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi -proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi -proc match_switch_case(x:literal(int),y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:literal(int),y:range(literal(int),literal(int)))=(x>=y._lo and x<=y._hi) +proc match_switch_case(x:literal(int),y:range(fix(int),fix(int)))=(x>=y._lo and x<=y._hi) proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi proc match_switch_case(x:,y:)=y inc x -type _crange is rec{_lo,_hi} -proc PM__caserange(x,y)=x..y -proc PM__caserange(x:fix(int),y:fix(int))=rec _crange{ - _lo=x,_hi=y -} // Conditional operators proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { @@ -1706,67 +1726,27 @@ proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) -/* -// Assignment -proc PM__assign_or_init(a,b)<>=a { - PM__assign_var(&^(a),b) -} -*/ - - -/* -type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... - -proc PM__assign(&a:any,b:any,c:assignment_operator) { - PM__assign(&a,c.(a,b)) -} -*/ proc PM__assign(&a:any,b:any,c:proc) { compile_error("Not a recognised assignment operator") } - -proc check_assign_types(x,y){ - test "Type mismatch in assignment"=>same_type(x,y) -} -proc _assign(&a,b) { - _assign_element(&a,b) -} -/* -proc _assign(&a:contains(farray),b) { - _assign_structure(&a,b) -} -*/ -/* -proc _assign_structure(&a,b)<>{ - _assign_element(&a,b) -} -proc _assign_structure(&a:farray,b){ - _array_assign(&a,b,fix(true)) -} -*/ PM__intrinsic _assign_element(&any,any): "assign" - -// Other variable operations - -proc PM__assign_or_init(&a:PM__assign_or_init,b)=PM__dup(b as a) - -proc PM__assign_or_init(&a,b)=a:PM__assign(&a,b) - -proc PM__init_const(&a:PM__assign_or_init,b)=PM__dup(b as a) - -proc PM__init_const(&a,b)=a: compile_error( "Cannot initialise a constant twice") - -proc PM__assign_var(&a,b) { - PM__assign(&a,b) +proc PM__assign(&a:any,b:any) { + PM__assign_var(&a,c) where c=convert(b,a) } -proc PM__dup(x)=x +proc PM__assign_var(&a:any,b:any) { + test "Cannot assign values"=>same_type(a,b) + _assign_element(&a,b) +} -proc PM__assign(&a:any,b:any) { - _assign(&a,c) where c=b as a +proc PM__assign_var(&a:a_rec,b:a_rec) { + test "Cannot assign different records"=>same_rec(a,b) + PM__each_index i in num_elements(a) { + PM__assign_var(&a.{i},b.{i}) + } } PM__intrinsic PM__clone(x:any)->(=x) : "clone" @@ -1782,36 +1762,28 @@ proc PM__init_const'(x:any,y:any)=PM__make_const'(x,y) proc PM__make_var(x,y)=PM__make_var(x as y) proc PM__make_const(x,y)=PM__make_const(x as y) PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" -/* -PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" -PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" -PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" -PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" -PM__intrinsic PM__dup(x:literal(int))->(int) : "clone" -PM__intrinsic PM__dup(x:literal(real))->(real) : "clone" -PM__intrinsic PM__dup(x:literal(string))->(string) : "clone" -PM__intrinsic PM__dup(x:literal(bool))->(bool) : "clone" -*/ PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" -PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" +PM__intrinsic same_type(x:any,y:any)->(==x,y) : "same_type_fold" +PM__intrinsic same_rec(x:any,y:any)->(==x,y) : "same_rec_fold" -/* -proc ==(x:any,y:any) { - test "Cannot apply ""=="" to different types"=> same_type(x,y) +proc ==(x:a_rec,y:a_rec) { + test "Cannot apply ""=="" to different records"=> same_rec(x,y) var ok=true _eq(x,y,&ok) return ok } proc /=(x:any,y:any) { - test "Cannot apply ""/="" to different types"=> same_type(x,y) + test "Cannot apply ""/="" to different records"=> same_rec(x,y) var ok=true _eq(x,y,&ok) return not ok } -proc _eq(x:any,y:any,&ok) <> { - ok=ok and x==y +proc _eq(x,y,&ok) <> { + PM__each_index i in num_elements(x) { + ok=ok and x.{i}==y.{i} + } } -*/ + proc PM__valref(x)=x proc PM__check_alias(...){} @@ -1824,23 +1796,15 @@ proc next_enum(x:int,y:int)=x+convert(y,x) PM__intrinsic<> .element_at_index(&x:any,y:fix(int))->(|x):"elem" PM__intrinsic<> element_at_index(x:any,y:fix(int))->(|x):"elem" -proc elements(x)=_elements(x,1) -proc _elements(x,i:literal(int)) { - let e... - if fix(i==num_elements(x)) { - let ...e=_cons(PM__element_at(x,i),_list_end) - } else { - let ...e=_cons(PM__element_at(x,i),_elements(x,i+1)) - } - return e -} // Type values PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" proc is(x,t)=t inc typeof(x) -proc isnt(x,t)=not(x is t) +proc isnot(x,t)=not(x is t) proc as(x,t:)...=PM__cast(x,t) -proc as(x,t)=PM__cast(x,typeof(t)) +proc as(x,t)=convert(x,t) +proc convert(x,t:a_poly or proc)=PM__cast(x,typeof(t)) +proc convert(x,t)=x PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" proc ==(x:,y:)=x inc y and y inc x PM__intrinsic error_type()->(=1) : "error_type" @@ -1849,19 +1813,7 @@ PM__intrinsic error_type()->(=1) : "error_type" PM__intrinsic<> _dump(any,any): "new_dump" proc PM__dump'(x)<>:_dump("Value:",x) proc PM__dump'(y,x)<>:if y:_dump("Value:",x) -/* -proc PM__dump%(x)<>{ - print("$"++here) - _dump(string(here),x) -} -proc PM__dump%(y:bool,x)<>{ - if y:_dump(string(here),x) -} -proc PM__dump%(y,x){ - test "Selection expression in ""$$dump"" not ""bool""" => fix(false) - $$infer_type(y) -} -*/ + PM__intrinsic<> old_dump(any): "dump" proc old_dumpit(a) { old_dump(a) diff --git a/src/array.f90 b/src/array.f90 index 853f528..05a8920 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -2978,7 +2978,7 @@ function vector_iota(context,& endif enddo enddo - call pm_dump_tree(context,6,vec,2) + !call pm_dump_tree(context,6,vec,2) ptr=vec contains include 'fesize.inc' diff --git a/src/codegen.f90 b/src/codegen.f90 index ef8b382..4504128 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -411,7 +411,7 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& sym=node_sym(node) if(debug_codegen) then write(*,*) 'TRAVERSE>',sym_names(sym),coder%vtop,vbase - !call dump_parse_tree(coder%context,6,node,2) + call dump_parse_tree(coder%context,6,node,2) endif select case(sym) case(sym_if,sym_if_invar) @@ -867,11 +867,9 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) call make_sys_call_rtn(coder,cblock2,node,sym_as,2,1) call hide_vars(coder,vb,vb) if(pm_fast_isnull(node_arg(node,2))) then - call trav_assign(coder,cblock2,node,node_arg(node,1),pm_null_obj,& - sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) + call trav_assign(coder,cblock2,node,node_arg(node,1),pm_null_obj) else - call trav_assign(coder,cblock2,node,node_arg(node,2),pm_null_obj,& - sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) + call trav_assign(coder,cblock2,node,node_arg(node,2),pm_null_obj) endif call reveal_vars(coder,vb,vb) endif @@ -1010,7 +1008,7 @@ subroutine trav_foreach_stmt(coder,cblock,pnode,node) call make_iter_lists(coder,cblock2,iter,node_numargs(iter),.true.,.false.) call trav_expr(coder,cblock2,node,node_arg(iter,2)) - call make_sys_call_rtn(coder,cblock2,node,sym_hash,1,1) + call make_comm_sys_call_rtn(coder,cblock2,node,sym_hash,1,1) if(base>=0) call hide_where_vars(coder,base+1,xtop) @@ -1073,7 +1071,7 @@ subroutine trav_for_stmt(coder,cblock,pnode,node) call make_iter_lists(coder,cblock,iter,node_numargs(iter),.true.,.true.) call trav_expr(coder,cblock,node,node_arg(iter,2)) - call make_sys_call_rtn(coder,cblock,node,sym_hash,1,1) + call make_comm_sys_call_rtn(coder,cblock,node,sym_hash,1,1) if(.not.pm_fast_isnull(keys)) then call trav_exprlist(coder,cblock,node,keys) @@ -1218,9 +1216,6 @@ recursive subroutine trav_all_stmt(coder,cblock,pnode,node) end subroutine trav_all_stmt - - - !======================================================== ! Traverse over statement !======================================================== @@ -1323,7 +1318,7 @@ subroutine make_iter_lists(coder,cblock,node,n,may_have_amp,may_have_star) k=node_sym(arg) if(k==sym_name.or.k==sym_reference) then call trav_reference(coder,cblock,node,arg,& - node_sym(node_arg(node,i))/=sym_amp,.true.,.false.) + node_sym(node_arg(node,i))==sym_amp,.true.,.false.) else call trav_expr(coder,cblock,node,node_arg(node,i+1)) endif @@ -1484,7 +1479,7 @@ subroutine make_block_proc(coder,cblock,node,namelist,amps,rtns,nret,stmtlist,it type(pm_ptr):: cblock2,cblock3,proc integer:: nargs,base,i,partype,restype,flags,vbase logical:: varargs - integer:: save_index,save_ncalls,save_state_base,save_mask + integer:: save_index,save_ncalls,save_state_base,save_mask,save_par_state integer:: name,signo,flags0,args(1) character(len=15):: namestr @@ -1610,17 +1605,23 @@ subroutine make_block_proc(coder,cblock,node,namelist,amps,rtns,nret,stmtlist,it endif call code_val(coder,coder%var(base+4)) cblock3=make_cblock(coder,cblock2,stmtlist,sym_do_stmt) - !coder%lex_scope=coder%lex_scope+1 + coder%lex_scope=push_lex_scope(coder) if(present(iters)) then call extract_iter_lists(coder,cblock3,iters,iter_amps,iter_stars) endif - + + save_par_state=coder%par_state + coder%par_state=par_state_comm_proc + call trav_open_stmt_list(coder,cblock3,node,stmtlist) call trav_xexpr(coder,cblock3,node,rtns) call make_sp_call(coder,cblock3,node,sym_result,nret,0) - !coder%lex_scope=coder%lex_scope-1 + + coder%par_state=save_par_state + + call pop_lex_scope(coder) call close_cblock(coder,cblock3) call extract_block_vars(coder,cblock2,node,coder%var(base+7),.true.) @@ -1687,8 +1688,9 @@ subroutine extract_var(coder,cblock,node,var,avar,index) call code_val(coder,var) call code_val(coder,avar) call make_long_const(coder,cblock,node,int(index,pm_ln)) - call make_comm_sys_call(coder,cblock,node,sym_elem_at_index,2,1,& - aflags=proccall_is_ref+proccall_is_general,assign=.true.) + call make_basic_sp_call(coder,cblock,node,sym_dot,2,1) +!!$ call make_comm_sys_call(coder,cblock,node,sym_elem_at_index,2,1,& +!!$ aflags=proccall_is_ref+proccall_is_general,assign=.true.) end subroutine extract_var !======================================================== @@ -1719,15 +1721,16 @@ recursive subroutine import_to_block_scope(coder,index,var,block_entry) integer,intent(in):: index,block_entry type(pm_ptr),intent(inout):: var integer:: var_scope,block_scope,block_links - if(debug_more_codegen) then - write(*,*) 'import_to_block_scope',block_entry,& - trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) - endif + if(block_entry==0) return var_scope=cnode_get_num(var,var_lex_scope) block_scope=coder%wstack(block_entry+2) block_links=coder%wstack(block_entry+3) if(var_scope>=block_scope) return + if(debug_more_codegen) then + write(*,*) 'import_to_block_scope',block_entry,var_scope,block_scope,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) + endif call make_var(coder,& coder%vstack(block_links+1),& pm_null_obj,& @@ -2015,6 +2018,7 @@ subroutine access_var(coder,var,modify) trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))),& cnode_get_num(var,var_index) endif + if(modify) then call cnode_set_flags(var,var_flags,var_is_changed) else @@ -2391,8 +2395,7 @@ recursive subroutine trav_sync_stmt(coder,cblock,pnode,node) if(sym==sym_open) then call trav_call(coder,cblock,node,body,0,.true.) elseif(sym==sym_assign) then - call trav_assign(coder,cblock,node,node_arg(body,1),node_arg(body,2),& - sym_sync_assign,sym_sync_assign_op,sym_sync_assign_ref) + call trav_assign(coder,cblock,node,node_arg(body,1),node_arg(body,2),is_sync=.true.) else call trav_stmt_list(coder,cblock,node,body,sym_sync,open_scope=.true.) endif @@ -2424,8 +2427,7 @@ recursive subroutine trav_assign_define(coder,cblock,pnode,node) sym=node_sym(lhs) n=lhs_size(lhs) if(n==1.and.sym==sym_assign) then - call trav_assign(coder,cblock,node,node_arg(lhs,1),rhs,& - sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) + call trav_assign(coder,cblock,node,node_arg(lhs,1),rhs) else call trav_rhs(coder,cblock,node,rhs,n) call trav_lhs(coder,cblock,node,lhs) @@ -2438,12 +2440,13 @@ end subroutine trav_assign_define ! $call_sym(var,expr,subs...) ! $call_sym_op(var,op,expr,subs...) - for op= ! $call_sym_ref(ref,ref) - for non-aliased refs + ! + ! If rhs is null then rhs value must by on top of vstack !============================================================== - subroutine trav_assign(coder,cblock,node,alhs,rhs,call_sym,& - call_sym_op,call_sym_ref) + subroutine trav_assign(coder,cblock,node,alhs,rhs,is_sync) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node,alhs,rhs - integer,intent(in):: call_sym,call_sym_op,call_sym_ref + logical,intent(in),optional:: is_sync integer:: base,n,is_op,sym logical:: hard_alias type(pm_ptr):: temp,lhs @@ -2469,10 +2472,10 @@ subroutine trav_assign(coder,cblock,node,alhs,rhs,call_sym,& call trav_reference(coder,cblock,node,lhs,.true.,.false.,.false.) call trav_reference(coder,cblock,node,rhs,.false.,.false.,.false.) if(coder%par_state==par_state_none) then - call make_sys_call(coder,cblock,node,call_sym_ref,2,0,& + call make_sys_call(coder,cblock,node,sym_pm_assign_ref,2,0,& assign=.true.) else - call make_comm_sys_call(coder,cblock,node,call_sym_ref,2,0,& + call make_comm_sys_call(coder,cblock,node,sym_pm_assign_ref,2,0,& assign=.true.) endif return @@ -2491,12 +2494,12 @@ subroutine trav_assign(coder,cblock,node,alhs,rhs,call_sym,& temp=coder%vstack(base) coder%vstack(base)=coder%vstack(base+is_op+1) coder%vstack(base+is_op+1)=temp - if(coder%par_state==par_state_none) then - call make_sys_call(coder,cblock,node,& - merge(call_sym_op,call_sym,is_op/=0),n+2+is_op,0,assign=.true.) - else + if(present(is_sync)) then call make_comm_sys_call(coder,cblock,node,& - merge(call_sym_op,call_sym,is_op/=0),n+2+is_op,0,assign=.true.) + merge(sym_pm_assign_op,sym_pm_assign,is_op/=0),n+2+is_op,0,assign=.true.) + else + call make_sys_call(coder,cblock,node,& + merge(sym_pm_assign_op,sym_pm_assign,is_op/=0),n+2+is_op,0,assign=.true.) endif contains include 'fisnull.inc' @@ -2554,8 +2557,7 @@ recursive subroutine trav_lhs(coder,cblock,node,lhs) enddo case(sym_assign) do i=n,1,-1 - call trav_assign(coder,cblock,lhs,node_arg(lhs,i),pm_null_obj,& - sym_pm_assign,sym_pm_assign_op,sym_pm_assign_ref) + call trav_assign(coder,cblock,lhs,node_arg(lhs,i),pm_null_obj) enddo case(sym_assign_list) do i=n,1,-1 @@ -2623,6 +2625,7 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) sym=node_sym(node) if(sym==sym_name) then call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) + if(present(call_n)) call_n=0 return endif @@ -2716,6 +2719,8 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) merge(sym_rhs,sym_lhs,islhs),n-i+1,1) endif endif + else + if(present(call_n)) call_n=0 end if if(isalias) then @@ -3226,7 +3231,8 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) case(sym_pm_each_index) call trav_pm_each_index(coder,cblock,pnode,node,.true.) case(sym_reference) - call trav_reference(coder,cblock,pnode,node,.false.,.true.,.false.) + call trav_reference(coder,cblock,pnode,node,.false.,.true.,.false.,call_n=n) + if(n>0) call make_comm_sys_call_rtn(coder,cblock,node,sym_get_ref,n+1,1) case(sym_open) call make_temp_var(coder,cblock,node) call dup_code(coder) @@ -3691,11 +3697,6 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,pm_type_new_unfixed) call push_word(coder,0) call trav_type(coder,pnode,name) - if(top_word(coder)/=0) then - call defer_type_check(coder,node,pnode,& - coder%literal_types,top_word(coder),sym_literal,& - cnode_is_arg_constraint) - endif call make_type(coder,3) end select case(sym_contains) @@ -3775,8 +3776,7 @@ recursive subroutine trav_type(coder,pnode,node) case(sym_pm_list) call push_word(coder,pm_type_new_vtuple+pm_type_is_list) call push_word(coder,0) - call push_word(coder,0) - call make_type(coder,3) + call make_type(coder,2) case(sym_assign,sym_var) call trav_type(coder,pnode,node_arg(node,1)) case(sym_pm_dref) diff --git a/src/infer.f90 b/src/infer.f90 index e5407f5..9b34795 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -1329,13 +1329,10 @@ subroutine inf_call(coder,cblock,callnode) if(tno==error_type.or.name==error_type) then call set_arg_to_error_type(1) else - tno=pm_type_strip_mode(coder%context,& - tno,mode) if(tno>0) then call set_call_sig(resolve_elem(cnode_arg(args,2),tno,name,& sig==sym_dot_ref,.false.,tno2)) - call combine_types(cnode_arg(args,1),& - pm_type_add_mode(coder%context,tno2,mode)) + call combine_types(cnode_arg(args,1),tno2) else call set_arg_to_error_type(1) endif @@ -1348,7 +1345,7 @@ subroutine inf_call(coder,cblock,callnode) if(tno>0) then if(pm_type_kind(coder%context,tno)/=pm_type_is_single_name) then tv=pm_type_vect(coder%context,arg_type(2)) - if(pm_tv_kind(tv)==pm_type_is_literal_value) then + if(pm_tv_kind(tv)==pm_type_is_literal_value.or.pm_tv_kind(tv)==pm_type_is_fix_value) then tno2=pm_tv_arg(tv,1) if(tno2==pm_string_type) then tno=pm_name_type_from_literal_string(coder%context,tno,& @@ -1361,11 +1358,15 @@ subroutine inf_call(coder,cblock,callnode) elseif(tno2/=pm_long) then call inf_error(coder,callnode,& 'Expression in ".{}" must be a literal string or integer') + call more_error(coder%context,'Got: '//trim(pm_type_as_string(coder%context,tno2))) + call inf_trace(coder) tno=error_type endif else call inf_error(coder,callnode,& 'Expression in ".{}" must be a literal string or integer') + call more_error(coder%context,'Got: '//trim(pm_type_as_string(coder%context,arg_type(2)))) + call inf_trace(coder) tno=error_type endif endif @@ -1509,8 +1510,12 @@ subroutine inf_call(coder,cblock,callnode) trim(pm_type_as_string(coder%context,tno))) endif if(pm_tv_kind(t)==pm_type_is_literal_value) then - tno=pm_new_fix_value_type(coder%context,pm_type_val(coder%context,tno),& - pm_tv_name(t)) + if(sig==sym_fix) then + tno=pm_new_fix_value_type(coder%context,pm_type_val(coder%context,tno),& + pm_tv_name(t)) + endif + else + tno=pm_new_literal_value_type(coder%context,pm_null_obj,0,tno) endif coder%stack(get_slot(1))=tno case(sym_dcaret) @@ -1751,10 +1756,10 @@ subroutine inf_each_index() 'Internal error: PM__each_index: not a literal or fix int parameter') endif else - n=1 + n=0 endif if(nret>1) then - call push_word(coder,pm_type_new_tuple) + call push_word(coder,pm_type_new_tuple+pm_type_is_list) call push_word(coder,0) endif do i=1,n @@ -1766,7 +1771,7 @@ subroutine inf_each_index() call inf_cblock(coder,cnode_arg(args,nret+2)) call code_int_vec(coder,coder%stack,coder%base+start,coder%base+finish) if(nret>1) then - call push_word(coder,arg_type(nret+4)) + call push_word(coder,arg_type_with_mode(nret+4)) endif enddo if(nret>1) then @@ -2122,7 +2127,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) logical:: is_comm,is_cond,is_unlabelled,ignore_rules integer:: name,mode,mode2,i,j,tno,tno2,slot,flags integer:: nargs,nkey,keybase,ressig,amps - logical:: undef_arg + logical:: undef_arg,bad_amp type(pm_ptr):: arg,keys,keynames,amplocs,proclist,t,tv nargs=num_args @@ -2147,6 +2152,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) endif undef_arg=.false. + bad_amp=.false. keys=cnode_get(callnode,call_keys) keynames=cnode_get(callnode,call_key_names) @@ -2207,9 +2213,9 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) endif ! Suspend 'no shared import' rule in system module code - ignore_rules=ignore_rules.or.& - cnode_get_name(callnode,cnode_modl_name)==sym_pm_system - +!!$ ignore_rules=ignore_rules.or.& +!!$ cnode_get_name(callnode,cnode_modl_name)==sym_pm_system +!!$ ! Implement mode combination rule for standard procedures mode=pm_type_combine_modes(coder%context,& coder%wstack(coder%wtop+1:coder%wtop+nargs),is_cond,& @@ -2250,6 +2256,7 @@ subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) call call_error('Cannot change "'//trim(sym_names(mode2))//& '" "&" variable outside of a "sync" statement') endif + bad_amp=.true. endif enddo endif @@ -2548,8 +2555,8 @@ function simple_proc_call(sig,procs,err,sig_start) result(ressig) enddo endif endif - if(new_apars>0.and.amps/=0) then - write(*,*) 'Changing to',trim(pm_type_as_string(coder%context,new_apars)) + if(new_apars>0.and.amps/=0.and..not.bad_amp) then +!!$ write(*,*) 'Changing to',trim(pm_type_as_string(coder%context,new_apars)) amplocs=pm_name_val(coder%context,amps) rtvect=pm_type_vect(coder%context,new_apars) if(pm_tv_kind(rtvect)==pm_type_is_tuple.and.& @@ -3395,8 +3402,8 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) logical:: ok,added typ0=get_var_type(coder,cnode,var,init=.true.) typ2=typ0 - write(*,*) 'Combining...',trim(pm_type_as_string(coder%context,typ0)),'<>',& - trim(pm_type_as_string(coder%context,typ)) +!!$ write(*,*) 'Combining...',trim(pm_type_as_string(coder%context,typ0)),'<>',& +!!$ trim(pm_type_as_string(coder%context,typ)) if(typ/=typ0) then if(typ0<=0) then typ2=typ @@ -3426,6 +3433,7 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) call cnode_error(coder,cnode,'Type inconsistency occurs here') endif typ2=error_type + call inf_trace(coder) elseif(added) then coder%types_changed=.true. endif @@ -3434,7 +3442,7 @@ subroutine combine_var_type(coder,cnode,var,typ,no_init) endif endif - write(*,*) '....to',trim(pm_type_as_string(coder%context,typ2)) +!!$ write(*,*) '....to',trim(pm_type_as_string(coder%context,typ2)) call set_var_type(coder,var,typ2) end subroutine combine_var_type @@ -3472,7 +3480,7 @@ function inf_cast(coder,node,tno1,tno2,isvar) result(k) if(.not.ok) then call inf_error(coder,node,& 'Value of type "'//trim(pm_type_as_string(coder%context,tno2))//& - '" cannot be converted to type "'//trim(pm_type_as_string(coder%context,tno1))//"'") + '" cannot be converted to type "'//trim(pm_type_as_string(coder%context,tno1))//'"') call inf_trace(coder) endif if(debug_inference) write(*,*) 'Cast Converts to:',trim(pm_type_as_string(coder%context,tno2)) @@ -3530,6 +3538,22 @@ function fold(coder,procnode,atype,rstype) result(rtype) rtype=coder%false_literal endif return + elseif(opcode==op_same_type_fold) then + ok=pm_type_equal(coder%context,pm_type_arg(coder%context,atype,2),pm_type_arg(coder%context,atype,3)) + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + return + elseif(opcode==op_same_rec_fold) then + ok=pm_type_same_rec(coder%context,pm_type_arg(coder%context,atype,2),pm_type_arg(coder%context,atype,3)) + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + return endif arg1=pm_type_val(coder%context,pm_tv_arg(tv,2)) if(n>1) then @@ -3797,6 +3821,7 @@ subroutine inf_error(coder,node,message,name) str=trim(pm_opts%error)//' '//message endif write(*,'(A)') trim(str) + write(*,*) endif if(cnode_get_name(node,cnode_modl_name)==sym_pm_system.and.& pm_opts%hide_sysmod) then diff --git a/src/parser.f90 b/src/parser.f90 index 64836ba..8f753ae 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1437,14 +1437,14 @@ end subroutine set_flags end function call_attr - !============================================================ + !==================================================================== ! Qualifiers ! .name .digit .{} [] .name() .{}() .() .'() .%() - ! Will immediately return true in dot_call if this is present - ! and just encountered a .() or .'() or .%() call + ! Will immediately return true in dot_call if dot_call is present + ! and parser just encountered a .() or .'() or .%() call ! Will return true in last_is_method if this present ! and qualifier finishes on a .name() or .{}() method call - !============================================================ + !==================================================================== recursive function qual(parser,dot_call,last_is_method) result(iserr) type(parse_state),intent(inout):: parser logical,intent(inout),optional:: dot_call,last_is_method @@ -1889,21 +1889,26 @@ recursive function term(parser,checkqual) result(iserr) case(sym_pm_list) call scan(parser) if(expect(parser,sym_open)) return - if(exprlist(parser,m,nolist=.true.)) return - if(expect(parser,sym_close)) return + if(parser%sym==sym_close) then + call scan(parser) + m=0 + else + if(exprlist(parser,m,nolist=.true.)) return + if(expect(parser,sym_close)) return + endif call make_node(parser,sym_pm_list,m) - case(sym_fix) + case(sym_fix,sym_literal) call scan(parser) if(parser%sym==sym_open_square) then call push_sym_val(parser,sym_tuple) if(subscript(parser)) return call simple_call(parser) - call make_node(parser,sym_fix,1) + call make_node(parser,sym,1) else if(expect(parser,sym_open)) return if(expr(parser)) return if(expect(parser,sym_close)) return - call make_node(parser,sym_fix,1) + call make_node(parser,sym,1) endif case(sym_null) if(parser%sym==sym_open) then diff --git a/src/types.f90 b/src/types.f90 index 00200a3..9e24e54 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -36,19 +36,20 @@ module pm_types integer,parameter:: pm_max_type_args=128 ! Flags for types - integer,parameter:: pm_type_has_storage=32 - integer,parameter:: pm_type_has_distributed=64 - integer,parameter:: pm_type_has_array=128 - integer,parameter:: pm_type_has_poly=256 - integer,parameter:: pm_type_has_generic=512 - integer,parameter:: pm_type_has_vect=1024 - integer,parameter:: pm_type_has_fix=2048 - integer,parameter:: pm_type_has_params=4096 - integer,parameter:: pm_type_is_recursive=8192 - integer,parameter:: pm_type_is_soa=16384 - integer,parameter:: pm_type_is_aos=32768 - integer,parameter:: pm_type_is_seq=65536 - integer,parameter:: pm_type_leaves=131072 + integer,parameter:: pm_type_has_storage= 2**5 + integer,parameter:: pm_type_has_distributed= 2**6 + integer,parameter:: pm_type_has_array= 2**7 + integer,parameter:: pm_type_has_poly= 2**8 + integer,parameter:: pm_type_has_generic= 2**9 + integer,parameter:: pm_type_has_vect= 2**10 + integer,parameter:: pm_type_has_fix= 2**11 + integer,parameter:: pm_type_has_literal= 2**12 + integer,parameter:: pm_type_has_params= 2**13 + integer,parameter:: pm_type_is_recursive= 2**14 + integer,parameter:: pm_type_is_soa= 2**15 + integer,parameter:: pm_type_is_aos= 2**16 + integer,parameter:: pm_type_is_seq= 2**17 + integer,parameter:: pm_type_leaves= 2**18 integer,parameter:: pm_type_is_when=16384 integer,parameter:: pm_type_is_yield=32768 @@ -79,7 +80,7 @@ module pm_types integer,parameter:: pm_type_new_par_kind=16 integer,parameter:: pm_type_new_proc_sig=17 integer,parameter:: pm_type_new_undef_result=18 - integer,parameter:: pm_type_new_literal_value=19 + integer,parameter:: pm_type_new_literal_value=19+pm_type_has_literal integer,parameter:: pm_type_new_except=20 integer,parameter:: pm_type_new_param=21+pm_type_has_params integer,parameter:: pm_type_new_gated=22 @@ -175,9 +176,8 @@ module pm_types ! Categorical types integer,public,parameter:: pm_a_rec_type = pm_last_sys_type + 1 integer,public,parameter:: pm_a_unique_type = pm_last_sys_type + 2 - integer,public,parameter:: pm_a_fix_type = pm_last_sys_type + 3 - integer,public,parameter:: pm_a_literal_type = pm_last_sys_type + 4 - integer,public,parameter:: pm_a_basic_type = pm_last_sys_type + 5 + integer,public,parameter:: pm_a_poly_type = pm_last_sys_type + 3 + integer,public,parameter:: pm_a_basic_type = pm_last_sys_type + 4 integer,public,parameter:: pm_last_category_type = pm_a_basic_type ! Literal types @@ -223,8 +223,7 @@ subroutine pm_init_types(context) 'prc_info ','string ',' ',& ' ',' ',' ',' ',& ' ',' ',' ',& - 'a_rec ','a_unique ','a_fix ','a_literal ',& - 'a_basic '/) + 'a_rec ','a_unique ','a_poly ','a_basic '/) context%tcache=pm_dict_new(context,128_pm_ln) context%pcache=pm_dict_new(context,1024_pm_ln) @@ -495,8 +494,8 @@ function pm_new_poly_val_type(context,etyp,vtyp) result(tno) integer:: tno integer,dimension(3):: args integer:: recur - write(*,*) 'New poly val: ',trim(pm_type_as_string(context,etyp)),' : ',& - trim(pm_type_as_string(context,vtyp)) +!!$ write(*,*) 'New poly val: ',trim(pm_type_as_string(context,etyp)),' : ',& +!!$ trim(pm_type_as_string(context,vtyp)) args(1)=pm_type_new_poly args(2)=etyp recur=-1 @@ -505,7 +504,7 @@ function pm_new_poly_val_type(context,etyp,vtyp) result(tno) if(recur>=0) then call pm_type_set_recursive_ref(context,recur,tno) endif - write(*,*) 'Poly type is:',tno +!!$ write(*,*) 'Poly type is:',tno end function pm_new_poly_val_type @@ -633,10 +632,10 @@ end function pm_fix_value_type_from_literal !========================================== ! Create new compile time value type !========================================== - function pm_new_literal_value_type(context,val,vindex) result(tno) + function pm_new_literal_value_type(context,val,vindex,typ) result(tno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val - integer,intent(in),optional:: vindex + integer,intent(in),optional:: vindex,typ integer:: tno integer,dimension(3):: args args(1)=pm_type_new_literal_value @@ -645,8 +644,12 @@ function pm_new_literal_value_type(context,val,vindex) result(tno) else args(2)=pm_set_add(context,context%names,val) endif - args(3)=pm_fast_typeof(val) - if(args(3)==pm_string.or.args(3)==pm_int32) args(3)=pm_string_type + if(present(typ)) then + args(3)=typ + else + args(3)=pm_fast_typeof(val) + if(args(3)==pm_string.or.args(3)==pm_int32) args(3)=pm_string_type + endif tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' @@ -752,7 +755,7 @@ function pm_type_flags(context,tno) result(flags) exit elseif(tno2/=0) then tv=pm_type_vect(context,tno2) - flags=pm_tv_flags(tv) + flags=ior(iand(pm_type_is_recursive,flags),pm_tv_flags(tv)) else flags=pm_type_has_generic exit @@ -1141,6 +1144,12 @@ function pm_type_mix_modes(context,array) result(mixed_mode) integer,intent(in),dimension(:):: array integer:: mixed_mode integer:: i,mode,cmax,cmin,tno + if(size(array)==0) then + ! Make sure zero length lists have private mode + ! as they are used in & arguments + mixed_mode=sym_private + return + endif cmax=sym_private cmin=sym_shared do i=1,size(array) @@ -1225,38 +1234,59 @@ function pm_type_equal(context,tno1,tno2) result(ok) logical:: ok type(pm_ptr):: tv1,tv2 integer:: typ1,typ2,tk1,tk2 - if(tno1==tno2) then - ok=.true. - else - tv1=pm_type_vect(context,tno1) - tv2=pm_type_vect(context,tno2) + typ1=tno1 + typ2=tno2 + tv1=pm_type_vect(context,typ1) + tv2=pm_type_vect(context,typ2) + tk1=pm_tv_kind(tv1) + tk2=pm_tv_kind(tv2) + do while(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) + typ1=pm_tv_arg(tv1,1) + tv1=pm_type_vect(context,typ1) tk1=pm_tv_kind(tv1) + enddo + do while(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) + typ2=pm_tv_arg(tv2,1) + tv2=pm_type_vect(context,typ2) tk2=pm_tv_kind(tv2) - typ1=tno1 - typ2=tno2 - if(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) then - typ1=pm_tv_arg(tv1,1) - endif - if(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) then - typ2=pm_tv_arg(tv2,1) - endif - ok=typ1==typ2 - if(.not.ok) then - tv1=pm_type_vect(context,typ1) - tv2=pm_type_vect(context,typ2) - tk1=pm_tv_kind(tv1) - tk2=pm_tv_kind(tv2) - if(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) then - typ1=pm_tv_arg(tv1,1) - endif - if(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) then - typ2=pm_tv_arg(tv2,1) - endif - ok=typ1==typ2 - endif - endif + enddo + ok=tno1==tno2 + if(.not.ok) ok=pm_type_includes(context,tno1,tno2,pm_type_incl_equiv) end function pm_type_equal + + !=========================================================================================== + ! Check if two concrete types are the same record (ignoring modes and vector type wrappers) + !============================================================================================ + function pm_type_same_rec(context,tno1,tno2) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno1,tno2 + logical:: ok + type(pm_ptr):: tv1,tv2 + integer:: typ1,typ2,tk1,tk2 + typ1=tno1 + typ2=tno2 + tv1=pm_type_vect(context,typ1) + tv2=pm_type_vect(context,typ2) + tk1=pm_tv_kind(tv1) + tk2=pm_tv_kind(tv2) + do while(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) + typ1=pm_tv_arg(tv1,1) + tv1=pm_type_vect(context,typ1) + tk1=pm_tv_kind(tv1) + enddo + do while(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) + typ2=pm_tv_arg(tv2,1) + tv2=pm_type_vect(context,typ2) + tk2=pm_tv_kind(tv2) + enddo + if(tk1/=pm_type_is_rec.and.tk1/=pm_type_is_tuple.or.tk1/=tk2) then + ok=.false. + else + ok=pm_tv_name(tv1)==pm_tv_name(tv2).and.pm_tv_numargs(tv1)==pm_tv_numargs(tv2) + endif + end function pm_type_same_rec + !=================================================================== ! Given a struct/rec template and type, return type parameters !================================================================== @@ -1433,7 +1463,12 @@ recursive function pm_test_type_includes(context,supertype,subtype,& params,base,user,ubase) return elseif(tk==pm_type_is_literal_value) then - ok=pm_tv_name(t)==pm_tv_name(u) + nt=pm_tv_name(t) + ok=nt==pm_tv_name(u) + if(ok.and.nt==0) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& + params,base,user,ubase) + endif return end if case(pm_type_is_fix,pm_type_is_literal) @@ -1619,7 +1654,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& else ok=pm_test_type_includes(context,pm_tv_name(t),pm_tv_name(u),& ior(mode,pm_type_incl_nomatch),params,base,user,ubase) - if(pm_tv_numargs(t)>0.and.pm_tv_numargs(u)>0) then + if(pm_tv_numargs(t)>0.and.pm_tv_numargs(u)>0.and.iand(mode,pm_type_incl_equiv)==0) then do i=1,pm_tv_numargs(u) do j=1,pm_tv_numargs(t) ok=pm_test_type_includes(context,pm_tv_arg(t,j),pm_tv_arg(u,i),& @@ -1889,10 +1924,8 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=uk==pm_type_is_rec case(pm_a_unique_type) ok=uk==pm_type_is_single_name - case(pm_a_literal_type) - ok=uk==pm_type_is_literal - case(pm_a_fix_type) - ok=uk==pm_type_is_fix + case(pm_a_poly_type) + ok=uk==pm_type_is_poly case(pm_a_basic_type) ok=uk==pm_type_is_basic case default @@ -2375,7 +2408,7 @@ function pm_literal_type_convert(context,partyp,argtyp) result(ctyp) integer:: ctyp integer:: tk - ctyp=pm_type_arg(context,argtyp,1) + ctyp=pm_type_for_var(context,pm_type_arg(context,argtyp,1),-1) tk=pm_type_kind(context,partyp) if(tk==pm_type_is_fix) then if(pm_type_includes(context,pm_type_arg(context,partyp,1),ctyp,& @@ -2430,7 +2463,11 @@ function pm_poly_type_convert(context,partyp,argtyp,converted_to_poly) result(ct if(pm_tv_kind(tv2)==pm_type_is_poly) then if(pm_type_includes(context,pm_tv_name(tv1),pm_tv_name(tv2),& pm_type_incl_type)) then - ctyp=partyp + if(pm_tv_numargs(tv2)>0) then + call remake(pm_tv_numargs(tv2)) + else + ctyp=partyp + endif endif else if(pm_type_includes(context,pm_tv_name(tv1),argtyp,& @@ -2440,6 +2477,27 @@ function pm_poly_type_convert(context,partyp,argtyp,converted_to_poly) result(ct endif endif endif + contains + subroutine remake(n) + integer,intent(in)::n + integer,dimension(n+2):: a + integer:: i,recur + a(1)=pm_type_new_poly + a(2)=pm_tv_name(tv1) + recur=-1 + do i=3,n+2 + a(i)=pm_tv_arg(tv2,i-2) + if(iand(pm_type_flags(context,a(i)),& + pm_type_has_poly+pm_type_is_recursive)/=0) then + if(recur<0) then + recur=pm_type_new_recursive_ref(context) + endif + a(i)=pm_type_move_recursive(context,a(i),recur) + endif + enddo + ctyp=pm_new_type(context,a) + if(recur>0) call pm_type_set_recursive_ref(context,recur,ctyp) + end subroutine remake end function pm_poly_type_convert @@ -2527,28 +2585,42 @@ end function pm_proc_type_conforms ! offset<0 Returns dref rather than sub-element ! If offset/=0 then etype returns the type of the element !================================================================= - recursive function pm_type_find_elem(context,tno,nametype,change,etype) result(offset) + recursive function pm_type_find_elem(context,value_type,name_type,change,etype) result(offset) type(pm_context),pointer:: context - integer,intent(in):: tno,nametype + integer,intent(in):: value_type,name_type logical,intent(in):: change integer,intent(out):: etype - integer:: offset,ptype,mode + integer:: offset,ptype,mode,nametype,tno type(pm_ptr):: tv,nameval,names integer:: tk,i,name - if(pm_type_kind(context,nametype)==pm_type_is_literal_value) then + + nametype=pm_type_strip_mode(context,name_type,mode) + tno=pm_type_strip_mode(context,value_type,mode) + tk=pm_type_kind(context,nametype) + if(tk==pm_type_is_literal_value.or.tk==pm_type_is_fix_value) then tv=pm_type_vect(context,tno) - if(pm_tv_kind(tv)==pm_type_is_rec) then - nameval=pm_type_val(context,nametype) - offset=nameval%data%ln(nameval%offset) + tk=pm_tv_kind(tv) + nameval=pm_type_val(context,nametype) + offset=nameval%data%ln(nameval%offset) + if(tk==pm_type_is_rec) then if(offset<=0.or.offset>pm_type_numargs(context,tno)) then offset=0 elseif(change) then names=pm_name_val(context,pm_tv_name(tv)) if(names%data%i(names%offset+offset)>0) offset=0 endif + if(offset/=0) etype=pm_type_arg(context,tno,offset) + elseif(tk==pm_type_is_tuple) then + if(offset<=0.or.offset>pm_type_numargs(context,tno)) then + offset=0 + else + etype=pm_type_arg(context,tno,offset) + endif + return else offset=0 endif + if(offset>0) etype=pm_type_add_mode(context,etype,mode) return endif name=pm_type_name(context,nametype) @@ -2564,17 +2636,28 @@ recursive function pm_type_find_elem(context,tno,nametype,change,etype) result(o select case(tk) case(pm_type_is_all) do i=1,pm_tv_numargs(tv) - offset=pm_type_find_elem(context,pm_tv_arg(tv,i),name,change,etype) + offset=pm_type_find_elem(context,pm_tv_arg(tv,i),nametype,change,etype) if(offset/=0) return enddo offset=0 return + case(pm_type_is_literal_value) + offset=pm_type_find_elem(context,pm_tv_arg(tv,1),nametype,change,etype) + tv=pm_type_vect(context,etype) + if(pm_tv_kind(tv)==pm_type_is_fix_value) then + etype=pm_new_literal_value_type(context,& + pm_type_val(context,etype),pm_type_name(context,etype)) + else + etype=pm_new_literal_value_type(context,& + pm_null_obj,0,etype) + endif case(pm_type_is_rec) call pm_type_elem_offset(context,tv,name,change,offset,etype) case default offset=0 return end select + if(offset>0) etype=pm_type_add_mode(context,etype,mode) end function pm_type_find_elem !================================================================ @@ -2680,7 +2763,9 @@ recursive function pm_type_for_var(context,tno,new_mode) result(typ) tk=pm_tv_kind(tv) select case(tk) case(pm_type_is_par_kind) - typ=pm_type_add_mode(context,pm_type_for_var(context,pm_tv_arg(tv,1),new_mode),new_mode) + if(new_mode>0) then + typ=pm_type_add_mode(context,pm_type_for_var(context,pm_tv_arg(tv,1),new_mode),new_mode) + endif case(pm_type_is_user) typ=pm_user_type_body(context,tno) case(pm_type_is_rec) @@ -2714,8 +2799,8 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) type(pm_ptr):: tv,tv2 integer:: tk,tk2 - write(*,*) 'combine types: ',trim(pm_type_as_string(context,tno)),' with ',& - trim(pm_type_as_string(context,tno2)) +!!$ write(*,*) 'combine types: ',trim(pm_type_as_string(context,tno)),' with ',& +!!$ trim(pm_type_as_string(context,tno2)) ok=.true. added=.false. @@ -2770,7 +2855,7 @@ recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) return endif call combine_poly(pm_tv_numargs(tv),pm_tv_numargs(tv2)) - write(*,*) 'Combined to: ',trim(pm_type_as_string(context,typ)),ok +!!$ write(*,*) 'Combined to: ',trim(pm_type_as_string(context,typ)),ok case default typ=-1 ok=.false. @@ -2800,8 +2885,8 @@ recursive subroutine combine_poly(n,n2) integer:: i,j,m,recur,typ2 logical:: elem_added,elem_ok - write(*,*) 'combine_poly',trim(pm_type_as_string(context,tno)),'<>',trim(pm_type_as_string(context,tno2)) - +!!$ write(*,*) 'combine_poly',trim(pm_type_as_string(context,tno)),'<>',trim(pm_type_as_string(context,tno2)) +!!$ a(1)=pm_type_new_poly a(2)=pm_tv_name(tv) do j=1,n @@ -2814,7 +2899,7 @@ recursive subroutine combine_poly(n,n2) outer:do i=1,n2 do j=1,n if(.not.mask(j)) then - write(*,*) 'Combining #',i,j +!!$ write(*,*) 'Combining #',i,j typ2=pm_type_combine(context,a(2+j),pm_tv_arg(tv2,i),elem_ok,elem_added) if(elem_ok) then added=added.or.elem_added @@ -2828,8 +2913,8 @@ recursive subroutine combine_poly(n,n2) a(m)=pm_tv_arg(tv2,i) enddo outer - write(*,*) 'combine poly',m,added - +!!$ write(*,*) 'combine poly',m,added +!!$ ! Nothing added so just return if(.not.added) then typ=tno @@ -2876,7 +2961,7 @@ end function pm_type_new_recursive_ref subroutine pm_type_set_recursive_ref(context,typ,tno) type(pm_context),pointer:: context integer,intent(in):: typ,tno - write(*,*) 'Set recursive',typ,tno +!!$ write(*,*) 'Set recursive',typ,tno call pm_type_set_val(context,typ,& pm_fast_typeno(context,tno)) contains @@ -2950,7 +3035,7 @@ recursive function pm_type_identify_recursive(context,tno,etyp,recur) result(typ recur=pm_type_new_recursive_ref(context) endif typ=recur - write(*,*) 'Made recur',typ +!!$ write(*,*) 'Made recur',typ endif end select contains @@ -2964,7 +3049,7 @@ recursive subroutine remake(n) a(i+2)=pm_type_identify_recursive(context,pm_tv_arg(tv,i),etyp,recur) enddo typ=pm_new_type(context,a) - write(*,*) 'remade to',typ,a +!!$ write(*,*) 'remade to',typ,a end subroutine remake end function pm_type_identify_recursive @@ -3369,7 +3454,7 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s if(add_char('literal(')) return endif if(pm_tv_name(tv)==0) then - call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,.true.) else if(pm_opts%show_details) then call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) @@ -3392,9 +3477,9 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s str(n:)=pm_value_as_string(context,nv) endif n=len_trim(str)+1 - if(.not.(tk==pm_type_is_fix_value.and.isfix)) then - if(add_char(')')) return - endif + endif + if(.not.(tk==pm_type_is_fix_value.and.isfix)) then + if(add_char(')')) return endif case(pm_type_is_fix) if(add_char('fix(')) return @@ -3651,10 +3736,16 @@ function show_equiv(name,templ,typ) result(ok) enddo name2=pm_name_stem(context,name) tuple=name2>=sym_dim1.and.name2<=sym_dim7 - if(name2==sym_range.and.params(1)/=params(2)) then - call pm_type_to_string(context,params(1),str,n,infix) - if(add_char('..')) return - call pm_type_to_string(context,params(2),str,n,infix) + if(name2==sym_range) then + if(params(1)/=params(2)) then + call pm_type_to_string(context,params(1),str,n,infix) + if(add_char('..')) return + call pm_type_to_string(context,params(2),str,n,infix) + else + if(add_char('range(')) return + call pm_type_to_string(context,params(1),str,n,infix) + if(add_char(')')) return + endif else if(.not.tuple) then call pm_name_string(context,name,str(n:)) diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 277812d..7909ba4 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -735,9 +735,11 @@ module pm_vmdefs integer,parameter:: op_concat_fold = -28 integer,parameter:: op_num_elems_fold = -29 integer,parameter:: op_type_include_fold = -30 - integer,parameter:: first_fold=-30 - integer,parameter:: op_clone_var = -31 - integer,parameter:: op_error_type = -32 + integer,parameter:: op_same_type_fold = -31 + integer,parameter:: op_same_rec_fold = -32 + integer,parameter:: first_fold=-32 + integer,parameter:: op_clone_var = -33 + integer,parameter:: op_error_type = -34 integer,parameter:: min_op=op_error_type integer,dimension(0:num_op):: op_flags @@ -2128,6 +2130,8 @@ subroutine set_op_names op_names(op_concat_fold)='concat_fold' op_names(op_num_elems_fold)='num_elems_fold' op_names(op_type_include_fold)='type_include_fold' + op_names(op_same_type_fold)='same_type_fold' + op_names(op_same_rec_fold)='same_rec_fold' op_names(op_clone_var)='clone_var' op_names(op_error_type)='error_type' diff --git a/src/wcoder.f90 b/src/wcoder.f90 index ac24ce6..cc99059 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -1257,6 +1257,7 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_chan,0,2,0,ve) call wc(wcd,-new_ve) case(sym_task) + !!! Needs restart etc. do i=3,nargs,3 break2=wcode_cblock(wcd,cnode_arg(args,i),rv,ve) enddo From 9fe222e0c09873f12bcaf1c3ee8f14fd7fb01eb5 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Thu, 3 Jul 2025 17:17:14 +0100 Subject: [PATCH 30/36] Assignment and references --- lib/sys/pm.pmm | 44 +++++++------------------------------ src/cnodes.f90 | 2 +- src/codegen.f90 | 49 ++++++++++++++++++++++++----------------- src/infer.f90 | 20 ++++++++++++++++- src/parser.f90 | 58 +++++++++++++++++++++++-------------------------- src/types.f90 | 53 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 137 insertions(+), 89 deletions(-) diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index 1b292f9..ddf6757 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -1460,7 +1460,8 @@ PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" proc array(x,d:extent)=_array(x,_mshape(d),size(d)) proc #'(x:any^any)=_array_mshape(x)._extent -proc element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) +proc _get_array_element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) +proc _set_array_element(a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(_array_mshape(a),t),v) /* PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" @@ -1556,42 +1557,9 @@ proc *(x:num,y:num^any)={ proc /(x:num^any,y:num)={ xx/y:xx in x } - - -// ***************************************** -// ARRAY TEMPLATES -// ***************************************** -// Array templates -type array_template(a,d:mshape or dshape,v:fix(bool)) is rec {_a:a,_d:d,_s:int,_v:v} -proc array(a:any,s:dshape)=rec array_template { - _a=a,_d=s,_s=s._size,_v=fix(false) -} -proc array(a:any,s:mshape(tuple(range(int))))=rec array_template { - _a=a,_d=s,_s=size(s),_v=fix(false) -} -proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) -proc varray(a:any,s:mshape or dshape)=rec array_template { - _a=a,_d=s,_s=size(s),_v=fix(true) -} -proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) -proc _zero(x)=0 -proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) -// Treat a template as if it were an array -proc _arb(a:array_template)=a._a -proc #(a:array_template(,mshape,))=a._d -proc dims(a:array_template(,mshape,))=dims(a._d) -proc size(a:array_template)=a._s -proc redim(a:array_template,d:mshape)= rec array_template { -_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s -proc element(a:array_template,...:subs)=a._a -// Array creation from template - -proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) -proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) -proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) - */ + // *************************************************** // LOOPS AND PARALLEL STATEMENTS // *************************************************** @@ -1727,7 +1695,7 @@ proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) -proc PM__assign(&a:any,b:any,c:proc) { +proc PM__assign_op(&a:any,b:any,c:proc) { compile_error("Not a recognised assignment operator") } @@ -1737,6 +1705,10 @@ proc PM__assign(&a:any,b:any) { PM__assign_var(&a,c) where c=convert(b,a) } +proc PM__assign(&a:any,b:any,j:tuple(int)) { + _set_array_element(&a,j,b) +} + proc PM__assign_var(&a:any,b:any) { test "Cannot assign values"=>same_type(a,b) _assign_element(&a,b) diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 0c44813..5b7fc73 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -144,7 +144,7 @@ module pm_cnodes integer,parameter:: var_is_par_var=2048 integer,parameter:: var_is_maybe_not_private=4096 integer,parameter:: var_is_where=8192 - integer,parameter:: var_is_split=16384 + integer,parameter:: var_is_reference=16384 ! Offsets into proc & builtin nodes integer,parameter:: pr_ptype=cnode_args+0 diff --git a/src/codegen.f90 b/src/codegen.f90 index 4504128..c3fdb65 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -2618,8 +2618,8 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) type(pm_ptr),intent(in):: cblock,pnode,node logical,intent(in):: islhs,skipdot,isalias integer,intent(out),optional:: call_n - type(pm_ptr):: arg - integer:: i,j,n,sym,start,base,vbase,abase,atop + type(pm_ptr):: arg,list,base_var + integer:: i,j,n,sym,start,base,vbase,abase,atop,last_caret logical:: iscomm,isvar sym=node_sym(node) @@ -2637,7 +2637,9 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) call trav_expr(coder,cblock,node,arg) isvar=.false. endif - + + base_var=top_code(coder) + start=2 arg=node_arg(node,start) sym=node_sym(arg) @@ -2667,6 +2669,7 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) base=coder%vtop-start+1 n=node_numargs(node) + last_caret=0 do i=start,n arg=node_arg(node,i) sym=node_sym(arg) @@ -2682,11 +2685,15 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) call trav_expr(coder,cblock,arg,node_arg(arg,1)) call trav_expr(coder,cblock,arg,node_arg(arg,2)) call make_sp_call_rtn(coder,cblock,node,sym_list,2,1) + case(sym_caret) + last_caret=i end select enddo atop=coder%vtop + call make_var(coder,cblock,node,0,var_is_reference,extra_info=base_var) + call dup_code(coder) call code_val(coder,coder%vstack(vbase)) i=start @@ -2694,9 +2701,17 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) if(skipdot) then arg=node_arg(node,i) sym=node_sym(arg) - do while(sym==sym_dot.or.sym==sym_open_brace) - call code_val(coder,coder%vstack(base+i)) - call make_sp_call_rtn(coder,cblock,arg,merge(sym_dot_ref,sym_dot,islhs),2,1) + do while(sym==sym_dot.or.sym==sym_open_brace.or.sym==sym_caret) + if(sym==sym_caret) then + list=node_arg(arg,2) + call trav_exprlist(coder,cblock,arg,list) + call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& + node_numargs(list),merge(1,-1,i==n)) + else + call code_val(coder,coder%vstack(base+i)) + call make_sp_call(coder,cblock,arg,merge(sym_dot_ref,sym_dot,islhs),2,& + merge(1,-1,i==n)) + endif i=i+1 if(i>n) exit arg=node_arg(node,i) @@ -2704,19 +2719,19 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) enddo endif - if(ibase) then - call name_vector(parser,base) - else - call push_null_val(parser) - endif - base=parser%top - call push_sym(parser,sym) - call scan(parser) - if(expr(parser)) return - n=1 - exit + if(check_name(parser,sym)) then + if(parser%sym==sym_assign) then + call make_node(parser,sym_list,m) + if(parser%top>base) then + call name_vector(parser,base) else - call push_back(parser,sym) + call push_null_val(parser) endif + base=parser%top + call push_sym(parser,sym) + call scan(parser) + if(expr(parser)) return + n=1 + exit + else + call push_back(parser,sym) endif - if(expr(parser)) return endif + if(expr(parser)) return m=m+1 endif if(parser%sym/=sym_comma) then @@ -1369,15 +1362,15 @@ recursive function arglist(parser,yield,dot) result(iserr) else call push_null_val(parser) endif - + ! Call attributes if present if(parser%sym==sym_open_attr) then if(call_attr(parser,.true.,flags)) return endif - + call push_num_val(parser,flags) call make_node_at(parser,sym_open,6,line,pos) - + if(m+n>pm_max_args) then call parse_error(parser,& 'Too many arguments to proc call - maximum is:'//trim(pm_int_as_string(pm_max_args))) @@ -1449,7 +1442,7 @@ recursive function qual(parser,dot_call,last_is_method) result(iserr) type(parse_state),intent(inout):: parser logical,intent(inout),optional:: dot_call,last_is_method logical:: iserr - integer:: sym,line,pos,n + integer:: sym,line,pos,n,m logical:: finish_on_method iserr=.true. n=1 @@ -1494,6 +1487,12 @@ recursive function qual(parser,dot_call,last_is_method) result(iserr) finish_on_method=.false. endif n=n+1 + case(sym_caret) + call scan(parser) + if(expect_name(parser)) return + if(expect(parser,sym_open)) return + if(exprlist(parser,m,nolist=.true.)) return + call make_node_at(parser,sym_caret,m+1,line,pos) case default if(expect_name(parser)) return sym=parser%sym @@ -2525,9 +2524,7 @@ end function rhs recursive function valref(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr - integer:: n iserr=.true. - n=0 if(expect_name(parser)) return if(parser%sym==sym_dcolon) then call scan(parser) @@ -2536,7 +2533,6 @@ recursive function valref(parser) result(iserr) else call make_node(parser,sym_name,1) end if - n=n+1 if(qual(parser)) return iserr=.false. end function valref diff --git a/src/types.f90 b/src/types.f90 index 9e24e54..8c8923e 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -2747,6 +2747,59 @@ recursive subroutine remake(n) end subroutine remake end function pm_type_as_concrete + + recursive function pm_type_replace(context,tno,oldtype,newtype) result(tno2) + type(pm_context),pointer:: context + integer,intent(in):: tno,oldtype,newtype + integer:: tno2 + type(pm_ptr):: tv + integer:: tk,oldtyp,newtyp + if(pm_type_kind(context,oldtype)==pm_type_is_dref) then + oldtyp=pm_type_arg(context,oldtype,1) + newtyp=pm_type_arg(context,newtype,1) + else + oldtyp=oldtype + newtyp=newtype + endif + if(tno==oldtyp) then + tno2=newtyp + return + endif + tv=pm_type_vect(context,tno) + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_array) + tno2=pm_new_arr_type(context,pm_tv_name(tv),& + pm_type_replace(context,pm_tv_arg(tv,1),oldtyp,newtyp),& + pm_tv_arg(tv,2),pm_tv_arg(tv,3)) + !!! Dref should be only be overall type (arg(1)?) + case(pm_type_is_rec,pm_type_is_tuple,pm_type_is_dref) + call remake(pm_tv_numargs(tv)) + case default + tno2=tno + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i,etyp + logical:: changed + a(1)=pm_tv_flags(tv) + a(2)=pm_tv_name(tv) + changed=.false. + do i=1,n + etyp=pm_tv_arg(tv,i) + a(i+2)=pm_type_replace(context,etyp,oldtyp,newtyp) + changed=changed.or.a(i+2)/=etyp + enddo + if(changed) then + tno2=pm_new_type(context,a) + else + tno2=tno + endif + end subroutine remake + end function pm_type_replace + !================================================================ ! Create a new type with with all fix values converted ! to base type and mode changed to new_mode From 375ccb1f84c7e00484372a909c97a432c1513b4a Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 4 Jul 2025 16:00:06 +0100 Subject: [PATCH 31/36] Non-distributed references --- lib/sys/pm.pmm | 46 ++++++++++++++++++++++++++++++++++++++-------- src/codegen.f90 | 30 +++++++++++++++++++++++------- src/infer.f90 | 18 +++++++++++++----- src/parser.f90 | 6 ++++-- src/symbol.f90 | 2 +- src/types.f90 | 4 +++- src/wcoder.f90 | 4 ++-- 7 files changed, 84 insertions(+), 26 deletions(-) diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index ddf6757..a3e68c2 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -1461,7 +1461,7 @@ PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" proc array(x,d:extent)=_array(x,_mshape(d),size(d)) proc #'(x:any^any)=_array_mshape(x)._extent proc _get_array_element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) -proc _set_array_element(a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(_array_mshape(a),t),v) +proc _set_array_element(&a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(_array_mshape(a),t),v) /* PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" @@ -1478,13 +1478,15 @@ proc _set_elem(&a:any^mshape,v,t:index){ PM__setaelem(&a,index(#(a),t),v) } -proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) -PM__intrinsic _make_subref(a:any^mshape,i:int)->(=a) : "make_rf" + PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" */ +proc _make_subref(a:any^any,t:tuple(int))=_make_subref(a,_point2index(_array_mshape(a),t)) +PM__intrinsic _make_subref(a:any^any,i:int)->(=a) : "make_rf" + type _mshape(ndim:dimension_number,contig:literal(bool)) is rec {_extent:extent(ndim),_m:tuple(int,ndim),_n:int,_o:int,_c:contig} proc _mshape(g:extent(1))=rec _mshape{_extent=g,_m=[1],_n=size(g.1),_o=o,_c=true} where o=-_point2index(dims(g),low(g)) proc _mshape(g:extent(2))=rec _mshape{_extent=g,_m=[1,s1],_n=s1*size(g.2),_o=o,_c=true} where s1=size(g.1) where o=-_point2index(dims(g),low(g)) @@ -1705,22 +1707,51 @@ proc PM__assign(&a:any,b:any) { PM__assign_var(&a,c) where c=convert(b,a) } -proc PM__assign(&a:any,b:any,j:tuple(int)) { +proc PM__assign(&a:any^any,b:any,j:tuple(int)) { _set_array_element(&a,j,b) } +proc PM__assign(&a:a_rec,b:any,j:literal(string or int)) { + PM__assign(*a.{j},b) +} + +proc PM__assign(&a:any^any,b:any,j:tuple(int),...) { + PM__assign(&a.^_make_subref(j),b,...) +} + +proc PM__assign(&a:a_rec,b:any,j:literal(string or int),...) { + PM__assign(&a.{j},b,...) +} + proc PM__assign_var(&a:any,b:any) { test "Cannot assign values"=>same_type(a,b) _assign_element(&a,b) } proc PM__assign_var(&a:a_rec,b:a_rec) { - test "Cannot assign different records"=>same_rec(a,b) + test "Cannot assign different records"=>same_rec(a,b) PM__each_index i in num_elements(a) { - PM__assign_var(&a.{i},b.{i}) + PM__assign(&a.^_element_at_index(i),b.{i}) } } +proc PM__assign(&a:literal,b:literal) { + test "Cannot assign values"=>same_type(a,b) +} + +proc PM__assign(&a:fix,b:fix) { + test "Cannot assign values"=>same_type(a,b) +} + +PM__intrinsic PM__get_ref(x:any)->(=x) : "get_rf" +proc PM__get_ref'(x)=PM__get_ref(x) +proc PM__get_ref'(x,...)=PM__get_ref(x,...) +proc PM__get_ref(x:a_rec,j:literal(int or string))=x.{j} +proc PM__get_ref(x:any^any,j:tuple(int))=_get_array_element(x,j) +proc PM__get_ref(x:a_rec,j:literal(int or string),...)=PM__get_ref(x.{j},...) +proc PM__get_ref(x:any^any,j:tuple(int),...)=PM__get_ref(_get_array_element(x,j),...) + + PM__intrinsic PM__clone(x:any)->(=x) : "clone" PM__intrinsic PM__make_var(x:any)->(=x) : "clone" priv PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv @@ -1734,7 +1765,6 @@ proc PM__init_const'(x:any,y:any)=PM__make_const'(x,y) proc PM__make_var(x,y)=PM__make_var(x as y) proc PM__make_const(x,y)=PM__make_const(x as y) PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" -PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" PM__intrinsic same_type(x:any,y:any)->(==x,y) : "same_type_fold" PM__intrinsic same_rec(x:any,y:any)->(==x,y) : "same_rec_fold" @@ -1766,7 +1796,7 @@ proc next_enum(x:int)=x+convert(1,x) proc next_enum(x:int,y:int)=x+convert(y,x) PM__intrinsic<> .element_at_index(&x:any,y:fix(int))->(|x):"elem" -PM__intrinsic<> element_at_index(x:any,y:fix(int))->(|x):"elem" +PM__intrinsic<> _element_at_index(x:any,y:fix(int))->(|x):"elem" // Type values diff --git a/src/codegen.f90 b/src/codegen.f90 index c3fdb65..8dfb576 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -2706,7 +2706,7 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) list=node_arg(arg,2) call trav_exprlist(coder,cblock,arg,list) call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& - node_numargs(list),merge(1,-1,i==n)) + node_numargs(list)+1,merge(1,-1,i==n)) else call code_val(coder,coder%vstack(base+i)) call make_sp_call(coder,cblock,arg,merge(sym_dot_ref,sym_dot,islhs),2,& @@ -2718,20 +2718,33 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) sym=node_sym(arg) enddo endif + + if(last_caret>=i) then + call code_error(coder,node,'Internal Error: ".^" not immediately resolved') + endif if(i<=n) then - do j=i,n - call code_val(coder,coder%vstack(base+j)) - enddo + if(present(call_n)) then + if(vbase+1/=base+i) then + do j=i,n + coder%vstack(vbase+j-i+1)=coder%vstack(base+j) + enddo + endif + coder%vtop=vbase+n-i+1 call_n=n-i+1 + if(isalias) call pm_panic('Alias reference (call_n)') + return else + do j=i,n + call code_val(coder,coder%vstack(base+j)) + enddo if(.not.iscomm) then call make_sys_call(coder,cblock,node,& - merge(sym_rhs,sym_lhs,islhs),n-i+2,1) + merge(sym_lhs,sym_get_ref,islhs),n-i+2,1) else call make_comm_sys_call(coder,cblock,node,& - merge(sym_rhs,sym_lhs,islhs),n-i+2,1) + merge(sym_lhs,sym_get_ref,islhs),n-i+2,1) endif endif else @@ -3396,6 +3409,9 @@ subroutine trav_name(coder,cblock,node,sym,name) endif else call trav_ref_to_var(coder,cblock,node,name,.false.) + if(cnode_flags_set(top_code(coder),var_flags,var_is_ref)) then + call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1) + endif endif contains @@ -3692,7 +3708,7 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,pm_type_new_fix) call push_word(coder,0) call trav_type(coder,pnode,name) - if(top_word(coder)==0) then + if(top_word(coder)/=0) then call defer_type_check(coder,node,pnode,& coder%literal_types,top_word(coder),sym_fix,& cnode_is_arg_constraint) diff --git a/src/infer.f90 b/src/infer.f90 index 3bdc9f8..6c6f6b0 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -811,7 +811,7 @@ function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype integer,dimension(1):: key integer:: k,t1,n,opcode type(pm_ptr):: tv,v - logical:: isstatic,iscomm + logical:: isstatic,iscomm,ok,added new_atype=-1 @@ -888,10 +888,10 @@ function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype endif else tv=pm_type_vect(coder%context,atype) - t1=pm_type_strip_mode(coder%context,pm_tv_arg(tv,8),mode) + t1=pm_type_strip_mode(coder%context,pm_tv_arg(tv,3),mode) v=pm_type_val(coder%context,t1) n=v%data%ln(v%offset) - t1=pm_type_strip_mode(coder%context,pm_tv_arg(tv,7),mode) + t1=pm_type_strip_mode(coder%context,pm_tv_arg(tv,2),mode) tv=pm_type_vect(coder%context,t1) k=pm_tv_kind(tv) if(k/=pm_type_is_rec.and.k/=pm_type_is_tuple) then @@ -915,7 +915,7 @@ function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype rtype=pm_new_arr_type(coder%context,sym_const,& pm_type_for_var(coder%context,atype1,sym_private),& pm_type_arg(coder%context,atype,3),int(pm_long)) - write(*,*) 'make array',pm_type_as_string(coder%context,atype) + !write(*,*) 'make array',pm_type_as_string(coder%context,atype) case(op_var_array) rtype=pm_new_arr_type(coder%context,sym_var,& pm_type_for_var(coder%context,atype1,sym_private),& @@ -958,7 +958,15 @@ function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype case(op_list_splice) call infer_list_splice case(op_assign) - new_atype=pm_type_arg(coder%context,atype,3) + new_atype=pm_type_combine(coder%context,& + pm_type_arg(coder%context,atype,2),pm_type_arg(coder%context,atype,3),ok,added) + case(op_array_set_elem) + new_atype=pm_new_arr_type(coder%context,pm_type_name(coder%context,atype1),& + pm_type_combine(coder%context,& + pm_type_arg(coder%context,atype1,1),& + pm_type_arg(coder%context,atype,4),ok,added),& + pm_type_arg(coder%context,atype1,2),& + pm_type_arg(coder%context,atype1,3)) end select ! Create cache entry diff --git a/src/parser.f90 b/src/parser.f90 index 78512e0..03fe026 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1491,8 +1491,10 @@ recursive function qual(parser,dot_call,last_is_method) result(iserr) call scan(parser) if(expect_name(parser)) return if(expect(parser,sym_open)) return - if(exprlist(parser,m,nolist=.true.)) return - call make_node_at(parser,sym_caret,m+1,line,pos) + if(exprlist(parser)) return + call make_node_at(parser,sym_caret,2,line,pos) + if(expect(parser,sym_close)) return + n=n+1 case default if(expect_name(parser)) return sym=parser%sym diff --git a/src/symbol.f90 b/src/symbol.f90 index 8488873..b0d2cac 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -839,7 +839,7 @@ module pm_symbol data sym_names(sym_this_node) /'this_node'/ data sym_names(sym_grid) /'grid'/ data sym_names(sym_indices) /'indices'/ - data sym_names(sym_get_ref) /'PM__getref'/ + data sym_names(sym_get_ref) /'PM__get_ref'/ data sym_names(sym_set_ref) /'PM__set_ref'/ data sym_names(sym_make_subref) /'PM__subref'/ data sym_names(sym_make_sublhs) /'PM__sublhs'/ diff --git a/src/types.f90 b/src/types.f90 index 8c8923e..c2dd7e1 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -3476,8 +3476,10 @@ recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_s if(add_char('varray(')) return elseif(name==sym_const) then if(add_char('farray(')) return - else + elseif(name==0) then if(add_char('array(')) return + else + if(add_char('array'//trim(pm_int_as_string(name))//'(')) return endif call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) if(add_char(',')) return diff --git a/src/wcoder.f90 b/src/wcoder.f90 index cc99059..d06c969 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -1891,8 +1891,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& op2=1 endif elseif(op==op_elem) then - if(nargs==9) then - tno=check_arg_type(wcd,args,rv,9) + if(nargs==4) then + tno=check_arg_type(wcd,args,rv,4) p=pm_type_val(wcd%context,tno) op2=p%data%ln(p%offset)+1 endif From cac6a7e10030f0e5b6b459385e7a9077af61313d Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 7 Jul 2025 16:52:42 +0100 Subject: [PATCH 32/36] PM__ref command --- lib/sys/pm.pmm | 27 ++++++++++++++++++--------- src/codegen.f90 | 30 ++++++++++++++++++++++-------- src/parser.f90 | 19 +++++++++++++++---- src/symbol.f90 | 4 ++-- src/vm.f90 | 5 +++++ src/vmdefs.f90 | 5 ++++- 6 files changed, 66 insertions(+), 24 deletions(-) diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index a3e68c2..2511159 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -1458,10 +1458,15 @@ PM__intrinsic<> _varray(x:any,y:any,z:any)->(=x) : "var_array" PM__intrinsic _array_mshape(x:any^any)->(=x) : "get_dom" PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +PM__intrinsic PM__setmaelem(&x:any^any,y:int,z:any): "array_set_multi_elem" proc array(x,d:extent)=_array(x,_mshape(d),size(d)) proc #'(x:any^any)=_array_mshape(x)._extent proc _get_array_element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) proc _set_array_element(&a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(_array_mshape(a),t),v) +proc _set_array_multi_element(&a:any^any,t:tuple(int),v):PM__setmaelem(&a,_point2index(_array_mshape(PM__import(a)),t),v) +proc _get_array_elementz(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(#(a),t)) +proc _set_array_elementz(&a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(#(a),t),v) +proc _set_array_multi_elementz(&a:any^any,t:tuple(int),v):PM__setmaelem(&a,_point2index(PM__import(#a),t),v) /* PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" @@ -1516,7 +1521,7 @@ proc _point2index(g:_mshape(7,literal(false)),p:tuple(int,7))=g._o+p.1+g._m.2*p. proc _point2index(g:_mshape,p:tuple(int))=0: compile_error("Rank mismatch in index") // Linear index of tuple of ranges or ints (zero base) -proc _indx(g:range(int),s)=int(s)-low(g) +proc _indx(g:range(int),s)=int(s) proc _indx(g:any_int,s)=int(s) proc _sz(x:int)=x proc _sz(x:range(int))=x._n @@ -1570,16 +1575,15 @@ proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) < PM__for size(shape) { let here_in_tile=PM__generate(shape,size(shape)) PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { - var inouts=PM__import(PM__inouts) - var inout_a_i=PM__import(PM__inout_a) - var inout_a=PM__get_elem(inout_a_i,here_in_tile) + PM__ref inouts=PM__import(PM__inouts) + var inout_a=PM__get_elem(PM__import(PM__inout_a),here_in_tile) PM__block_proc.'(&inouts, PM__import(PM__ins), &inout_a, PM__get_elem(PM__import(PM__in_a),here_in_tile), PM__get_elem(PM__import(PM__star_a),here_in_tile) <>) PM__export(&PM__inouts,inouts) - PM__set_elem(&inout_a_i,inout_a,here_in_tile) + PM__set_multi_elem(&PM__inout_a,inout_a,here_in_tile <>) } } } @@ -1628,8 +1632,12 @@ proc PM__check_iter_amp(x,y){} proc PM__check_iter_star(x,y){} proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):PM__get_elem(x.{i},h)) +proc PM__get_elem(x:any^any,h)=_get_array_elementz(x,h) proc PM__get_elem(x,h)=element(x,h) -proc PM__set_elem(&x,y,h) {} +proc PM__set_elem(&x:PM__list,y,h):PM__each_index i in num_elements(x){PM__set_elem(&x.{i},y.{i},h <>)} +proc PM__set_elem(&x:any^any,y,h) {_set_array_elementz(&x,h,y)} +proc PM__set_multi_elem(&x:PM__list,y,h):PM__each_index i in num_elements(x){PM__set_multi_elem(&x.{i},y.{i},h <>)} +proc PM__set_multi_elem(&x:any^any,y,h) {_set_array_multi_elementz(&x,h,y)} proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(x.{i})) PM__intrinsic PM__import(x:any)->(=x) : "import_val" @@ -1738,7 +1746,6 @@ proc PM__assign_var(&a:a_rec,b:a_rec) { proc PM__assign(&a:literal,b:literal) { test "Cannot assign values"=>same_type(a,b) } - proc PM__assign(&a:fix,b:fix) { test "Cannot assign values"=>same_type(a,b) } @@ -1746,11 +1753,13 @@ proc PM__assign(&a:fix,b:fix) { PM__intrinsic PM__get_ref(x:any)->(=x) : "get_rf" proc PM__get_ref'(x)=PM__get_ref(x) proc PM__get_ref'(x,...)=PM__get_ref(x,...) -proc PM__get_ref(x:a_rec,j:literal(int or string))=x.{j} +proc PM__get_ref(x:a_rec,j:literal(int or string) or a_unique)=x.{j} proc PM__get_ref(x:any^any,j:tuple(int))=_get_array_element(x,j) -proc PM__get_ref(x:a_rec,j:literal(int or string),...)=PM__get_ref(x.{j},...) +proc PM__get_ref(x:a_rec,j:literal(int or string) or a_unique,...)=PM__get_ref(x.{j},...) proc PM__get_ref(x:any^any,j:tuple(int),...)=PM__get_ref(_get_array_element(x,j),...) +proc PM__subs(x,...)=tuple(x,...) +proc PM__subs(x:tuple)=x PM__intrinsic PM__clone(x:any)->(=x) : "clone" PM__intrinsic PM__make_var(x:any)->(=x) : "clone" priv diff --git a/src/codegen.f90 b/src/codegen.f90 index 8dfb576..b1eba5a 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -58,7 +58,7 @@ module pm_codegen logical,parameter:: debug_codegen=.false. logical,parameter:: debug_more_codegen=.false. - + ! Limits integer,parameter:: max_code_stack=4096 integer,parameter:: code_local_hash=1024 @@ -712,6 +712,13 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call get_lex_scope(coder,node) call make_sp_call(coder,cblock,node,sym_pm_foreach,3,0) call pop_lex_scope(coder) + case(sym_pm_ref) + call trav_expr(coder,cblock,node,node_arg(node,2)) + if(cnode_get_kind(top_code(coder))/=cnode_is_var) then + call code_error(coder,node,'Internal error: PM__ref expression does not yield var') + endif + call cnode_set_flags(top_code(coder),var_flags,var_is_var) + call push_var(coder,node_num_arg(node,1),pop_code(coder)) case(sym_repl_line) call trav_xexpr(coder,cblock,node,node_arg(node,1)) call make_sys_call(coder,cblock,node,sym_print,1,0) @@ -2703,10 +2710,15 @@ subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) sym=node_sym(arg) do while(sym==sym_dot.or.sym==sym_open_brace.or.sym==sym_caret) if(sym==sym_caret) then - list=node_arg(arg,2) - call trav_exprlist(coder,cblock,arg,list) - call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& - node_numargs(list)+1,merge(1,-1,i==n)) + if(node_numargs(arg)>1) then + list=node_arg(arg,2) + call trav_exprlist(coder,cblock,arg,list) + call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& + node_numargs(list)+1,merge(1,-1,i==n)) + else + call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& + 1,merge(1,-1,i==n)) + endif else call code_val(coder,coder%vstack(base+i)) call make_sp_call(coder,cblock,arg,merge(sym_dot_ref,sym_dot,islhs),2,& @@ -2804,7 +2816,7 @@ subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) if(islhs) then if(cnode_get_kind(var)==cnode_is_var) then flags=cnode_get_num(var,var_flags) - if(iand(flags,var_is_var)==0.and..false.) then + if(iand(flags,var_is_var)==0) then call code_error(coder,pnode,& 'Cannot assign to constant: ',name) else @@ -3409,8 +3421,10 @@ subroutine trav_name(coder,cblock,node,sym,name) endif else call trav_ref_to_var(coder,cblock,node,name,.false.) - if(cnode_flags_set(top_code(coder),var_flags,var_is_ref)) then - call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1) + if(cnode_get_kind(top_code(coder))==cnode_is_var) then + if(cnode_flags_set(top_code(coder),var_flags,var_is_ref)) then + call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1) + endif endif endif diff --git a/src/parser.f90 b/src/parser.f90 index 03fe026..a5d6ee9 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1491,9 +1491,14 @@ recursive function qual(parser,dot_call,last_is_method) result(iserr) call scan(parser) if(expect_name(parser)) return if(expect(parser,sym_open)) return - if(exprlist(parser)) return - call make_node_at(parser,sym_caret,2,line,pos) - if(expect(parser,sym_close)) return + if(parser%sym==sym_close) then + call scan(parser) + call make_node_at(parser,sym_caret,1,line,pos) + else + if(exprlist(parser)) return + call make_node_at(parser,sym_caret,2,line,pos) + if(expect(parser,sym_close)) return + endif n=n+1 case default if(expect_name(parser)) return @@ -1529,7 +1534,7 @@ recursive function qual(parser,dot_call,last_is_method) result(iserr) n=n+1 case(sym_open_square) call get_sym_pos(parser,line,pos) - call push_sym_val(parser,sym_tuple) + call push_sym_val(parser,sym_pm_subs) if(subscript(parser)) return call simple_call(parser) call make_node_at(parser,sym_sub,1,line,pos) @@ -3468,6 +3473,12 @@ recursive subroutine stmt_list(parser,single,num_to_include) if(expr(parser)) goto 999 if(expect(parser,sym_close)) goto 999 call make_node(parser,sym_pm_set_dotdotdot,1) + case(sym_pm_ref) + call scan(parser) + if(expect_name(parser)) return + if(expect(parser,sym_assign)) return + if(expr(parser)) return + call make_node(parser,sym_pm_ref,2) ! Pragma's -- start with $$ case(sym_ddollar) diff --git a/src/symbol.f90 b/src/symbol.f90 index b0d2cac..ad2faa1 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -301,7 +301,7 @@ module pm_symbol integer,parameter:: sym_result = node0 + 10 integer,parameter:: sym_sub = node0 + 11 integer,parameter:: sym_method_call = node0 + 12 - integer,parameter:: sym_dot_sub = node0 + 13 + integer,parameter:: sym_pm_subs = node0 + 13 integer,parameter:: sym_unused_node = node0 +14 integer,parameter:: sym_array_former = node0 + 15 integer,parameter:: sym_matrix_former = node0 + 16 @@ -778,7 +778,7 @@ module pm_symbol data sym_names(sym_result) /''/ data sym_names(sym_sub) /'[]'/ data sym_names(sym_method_call) /''/ - data sym_names(sym_dot_sub) /''/ + data sym_names(sym_pm_subs) /'PM__subs'/ data sym_names(sym_unused_node) /''/ data sym_names(sym_array_former) /''/ data sym_names(sym_matrix_former) /'PM__matrix'/ diff --git a/src/vm.f90 b/src/vm.f90 index b7f98f3..b8b49e3 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -1411,6 +1411,11 @@ recursive function pm_run(context,funcin,stackin,pcin,& errno=0 call array_set_index(context,arg(2),arg(3),arg(4),ve,errno) if(errno/=0) goto 997 + case(op_array_set_multi_elem) + errno=0 + call array_set_index(context,import_vector(context,& + arg(2),arg(1)%data%ptr(arg(1)%offset+1)),arg(3),arg(4),ve,errno) + if(errno/=0) goto 997 case(op_get_dom) call set_arg(2,array_dom(context,arg(3),esize)) case(op_get_size) diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 7909ba4..7e1884d 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -137,8 +137,9 @@ module pm_vmdefs integer,parameter:: op_redim = op_misc2 + 21 integer,parameter:: op_wshare = op_misc2 + 22 integer,parameter:: op_block_cyclic = op_misc2 + 23 + integer,parameter:: op_array_set_multi_elem = op_misc2 + 24 - integer,parameter:: op_misc3 = op_block_cyclic + integer,parameter:: op_misc3 = op_array_set_multi_elem integer,parameter:: op_get_esize = op_misc3 + 1 integer,parameter:: op_pack = op_misc3 + 2 @@ -860,6 +861,7 @@ module pm_vmdefs data op_flags(op_redim) /0/ data op_flags(op_wshare) /0/ data op_flags(op_block_cyclic) /0/ + data op_flags(op_array_set_multi_elem) /0/ data op_flags(op_pack) /0/ data op_flags(op_dref) /0/ data op_flags(op_dref_elem) /0/ @@ -1564,6 +1566,7 @@ subroutine set_op_names op_names(op_redim)='redim' op_names(op_wshare)='wshare' op_names(op_block_cyclic)='block_cyclic' + op_names(op_array_set_multi_elem)='array_set_multi_elem' op_names(op_pack)='pack' op_names(op_dref)='dref' op_names(op_dref_elem)='dref_elem' From fd44afb24ce64490de55b9e1f478f33488d48b1c Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 11 Jul 2025 16:20:28 +0100 Subject: [PATCH 33/36] Keyword args fix and drop --- src/ast.f90 | 3 + src/cnodes.f90 | 15 +++ src/codegen.f90 | 24 ++-- src/infer.f90 | 343 +++++++++++++++++++++++++++++++++++++++++++----- src/parser.f90 | 15 ++- src/types.f90 | 50 ++++--- src/vm.f90 | 13 +- src/vmdefs.f90 | 2 +- src/wcoder.f90 | 44 ++++--- 9 files changed, 408 insertions(+), 101 deletions(-) diff --git a/src/ast.f90 b/src/ast.f90 index 4a01fae..a6726ea 100644 --- a/src/ast.f90 +++ b/src/ast.f90 @@ -142,6 +142,9 @@ module pm_ast + proc_is_dcomm + proc_is_file & + proc_prints_out + integer,parameter:: proc_must_run= proc_is_dcomm & + + proc_is_file + proc_prints_out + ! Flags for proc calls integer,parameter:: call_ignore_rules= 512 integer,parameter:: call_is_fixed = 2**10 diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 5b7fc73..5ecc558 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -182,6 +182,21 @@ module pm_cnodes integer,parameter:: sp_sig_dup=-5_pm_p integer,parameter:: sp_sig_noop=-6_pm_p integer,parameter:: sp_sig_setval=-7_pm_p + + integer,parameter:: sp_sig_deactivated=-huge(1) + + ! Access codes + ! Note - if change access_kind then need to + ! check for and change any %data%i8 accesses + ! in bprop routines + integer,parameter:: access_kind=pm_i8 + integer(pm_p),parameter:: access_pm_type=pm_int8 + integer(access_kind),parameter:: access_deactivated_call=-1 + integer(access_kind),parameter:: access_is_var=1 + integer(access_kind),parameter:: access_used_ever=2 + integer(access_kind),parameter:: access_used_now=4 + integer(access_kind),parameter:: access_everything=& + access_is_var+access_used_ever+access_used_now contains diff --git a/src/codegen.f90 b/src/codegen.f90 index b1eba5a..570803e 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -3263,11 +3263,12 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,1)) call make_sys_call_rtn(coder,cblock,node,sym_ge,2,1) - case(sym_pm_dref:sym_pm_ref) - do i=1,node_numargs(node) + case(sym_pm_ref) + call code_val(coder,node_arg(node,1)) + do i=2,node_numargs(node) call trav_expr(coder,cblock,node,node_arg(node,i)) enddo - call make_sp_call_rtn(coder,cblock,node,sym,node_numargs(node),1) + call make_sp_call_rtn(coder,cblock,node,sym_pm_ref,node_numargs(node),1) case(sym_pm_each_index) call trav_pm_each_index(coder,cblock,pnode,node,.true.) case(sym_reference) @@ -5045,8 +5046,8 @@ recursive subroutine trav_proc(coder,node) pr_flags=flags if(iand(flags,proc_run_shared+proc_run_local+proc_run_complete)/=0) then call code_params(cblock,.true.,argcall) - call export_params(cblock) call code_keys(cblock,tkeys,keycall,.true.,.true.) + call export_params(cblock) call code_special_check_body_and_result(cblock) elseif(iand(flags,proccall_is_comm)/=0) then coder%par_state=merge(par_state_comm_proc,par_state_none,& @@ -5057,8 +5058,6 @@ recursive subroutine trav_proc(coder,node) else coder%par_state=par_state_none call code_params(cblock,.false.,argcall) - call make_state_vars(coder,cblock,node,& - topo=coder%var(coder%proc_base+1)) call code_keys(cblock,tkeys,keycall,.false.,.false.) call code_check(cblock) call code_body(cblock) @@ -5211,6 +5210,10 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) if(pm_fast_isnull(p)) then tkeys=pm_null_obj key_call=pm_null_obj + if(.not.(iscomm.or.isshrd)) then + call make_state_vars(coder,cblock,node,& + topo=coder%var(coder%proc_base+1)) + endif return endif n=node_numargs(p)/3 @@ -5262,12 +5265,17 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) enddo call hide_vars(coder,base+1,coder%top) - + + if(.not.(iscomm.or.isshrd)) then + call make_state_vars(coder,cblock,node,& + topo=coder%var(coder%proc_base+1)) + endif + ! Create blocks to compute default values do i=1,node_numargs(p),3 cblock2=make_cblock(coder,cblock,node,sym_key) call trav_expr(coder,cblock2,p,node_arg(p,i+2)) - tno=tkeys%data%i(tkeys%offset+n+i-1) + tno=tkeys%data%i(tkeys%offset+n+i/3) ! For stated type constraints, convert default value to ! that type if(tno>=0) then diff --git a/src/infer.f90 b/src/infer.f90 index 6c6f6b0..d0a3555 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -1119,7 +1119,7 @@ subroutine inf_call(coder,cblock,callnode) coder%loop_depth=coder%loop_depth+1 counter=0 do - coder%types_changed=.false. + if(coder%loop_depth==1) coder%types_changed=.false. call inf_cblock(coder,list) call check_logical(2,sig==sym_while_invar) if(arg_type(2)==coder%false_fix) return @@ -1140,7 +1140,7 @@ subroutine inf_call(coder,cblock,callnode) coder%loop_depth=coder%loop_depth+1 counter=0 do - coder%types_changed=.false. + if(coder%loop_depth==1) coder%types_changed=.false. call inf_cblock(coder,list) if(.not.coder%types_changed.or.coder%loop_depth>1) exit counter=counter+1 @@ -1212,36 +1212,14 @@ subroutine inf_call(coder,cblock,callnode) call inf_cblock(coder,cnode_arg(args,nargs)) case(sym_pm_head_node) call inf_cblock(coder,cnode_arg(args,1)) - case(sym_pm_dref:sym_pm_ref) + case(sym_pm_ref) call push_word(coder,pm_type_new_dref) - slot=coder%wtop - call push_word(coder,sym_pm_dref-sig-1) - if(nargs==3) then - t=pm_type_vect(coder%context,arg_type(3)) - call push_word(coder,arg_type_with_mode(2)) - call push_word(coder,arg_type_with_mode(3)) - call push_word(coder,arg_type_with_mode(4)) - call push_word(coder,pm_tv_arg(t,4)) - call push_word(coder,pm_tv_arg(t,5)) - tno=0 - tno2=pm_tv_flags(t) - coder%wstack(slot)=ior(coder%wstack(slot),tno) - call make_type_if_possible(coder,7) - else - do i=1,nargs - call push_word(coder,arg_type_with_mode(i+1)) - enddo - if(debug_inference) then - do i=4,0,-1 - write(*,*) 'DREF[',i,']',& - trim(pm_type_as_string(coder%context,coder%wstack(coder%wtop-i))) - enddo - endif - call make_type_if_possible(coder,nargs+2) - endif - if(debug_inference) write(*,*) 'DREF=',& - trim(pm_type_as_string(coder%context,top_word(coder))) - coder%stack(get_slot(1))=pop_word(coder) + call push_word(coder,cnode_num_arg(args,2)) + do i=2,nargs + call push_word(coder,arg_type_with_mode(i+1)) + enddo + call make_type(coder,nargs+1) + call combine_types(cnode_arg(args,1),pop_word(coder)) case(sym_pm_each_index) call inf_each_index case(sym_pm_set_dotdotdot) @@ -3763,6 +3741,309 @@ subroutine make_type_if_possible(coder,n) call make_type(coder,n) end subroutine make_type_if_possible + + subroutine bprop(coder,cblock,nargs,rvec,frame_size) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,rvec + integer,intent(in):: nargs,frame_size + integer(access_kind),allocatable,dimension(:):: access_info + integer:: save_loop_depth,i + allocate(access_info(frame_size)) + access_info=0 + save_loop_depth=coder%loop_depth + call bprop_cblock(coder,cblock,access_info,rvec) + coder%loop_depth=save_loop_depth + do i=1,frame_size + if(access_info(i)==access_deactivated_call.or.& + access_info(i)==access_is_var) then + rvec%data%i(rvec%offset)=sp_sig_deactivated + endif + end do + deallocate(access_info) + end subroutine bprop + + + !========================================== + ! Back propogate information for code block + !========================================== + subroutine bprop_cblock(coder,cblock,access_info,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,rvec + integer(access_kind),dimension(*),intent(inout):: access_info + integer:: nvars,i,newbase + type(pm_ptr):: p + if(pm_fast_isnull(cblock)) return + p=cnode_get(cblock,cblock_last_call) + do while(.not.pm_fast_isnull(p)) + call inf_call(coder,cblock,p) + p=cnode_get(p,call_back_link) + enddo + contains + include 'fisnull.inc' + end subroutine bprop_cblock + + subroutine bprop_call(coder,cblock,callnode,access_info,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,cblock,rvec + integer(access_kind),dimension(*),intent(inout):: access_info + type(pm_ptr):: args,arg,procnode + integer:: nret,sig,nargs,opcode,i + nret=cnode_get_num(callnode,call_nret) + sig=-cnode_get_num(callnode,call_sig) + args=cnode_get(callnode,call_args) + nargs=cnode_numargs(args)-nret + call enable + if(sig>0) then + select case(sig) + case(sym_while,sym_while_invar) + coder%loop_depth=coder%loop_depth+1 + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + if(coder%loop_depth==1) then + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + endif + case(sym_until,sym_until_invar) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + if(coder%loop_depth==1) then + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + endif + case(sym_if,sym_if_invar) + call bprop_if(count_updates(cnode_arg(args,4),1)) + case(sym_task) + + case(sym_pm_ref) + call std_access(.true.,2) + case(sym_open) + call code_val(coder,pm_new(coder%context,access_pm_type,int(max(nargs,1),pm_ln))) + arg=top_code(coder) + do i=1,nargs + arg%data%i8(arg%offset+i-1)=get_access_info(cnode_arg(args,i)) + enddo + case(sym_key) + do i=2,nargs,2 + if(accessed(cnode_arg(args,i/2+nret/2))) then + call access(cnode_arg(args,nret+i)) + endif + call bprop_cblock(coder,cnode_arg(args,nret+i-1),access_info,rvec) + enddo + call code_val(coder,pm_new(coder%context,access_pm_type,int(max(nret/2,1),pm_ln))) + arg=top_code(coder) + do i=nret/2+1,nret + arg%data%i8(arg%offset+i-1)=get_access_info(cnode_arg(args,i)) + enddo + case(sym_amp,sym_result) + do i=1,nargs + call set_access_info(cnode_arg(args,i),access_everything) + enddo + case default + call std_access(.true.,1) + end select + else + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(rvec%data%i(rvec%offset+cnode_get_num(callnode,call_index)),pm_ln)) + if(cnode_get_kind(procnode)==cnode_is_autoconv_sig) then + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(cnode_num_arg(procnode,cnode_numargs(procnode)),pm_ln)) + endif + if(cnode_get_kind(procnode)==cnode_is_resolved_proc) then + call bprop_proc_call + else + opcode=cnode_get_num(procnode,bi_opcode) + select case(opcode) + case(op_assign) + if(accessed(cnode_arg(args,2))) then + call access(cnode_arg(args,3)) + call modify(cnode_arg(args,2)) + else + call disable + endif + case default + call std_access(.true.,1) + end select + endif + endif + contains + + include 'fesize.inc' + include 'fisnull.inc' + + subroutine bprop_if(nupdates) + integer:: nupdates + type(pm_ptr):: readlist,p,var + integer(access_kind),dimension(nupdates):: save_access + integer:: i + integer(access_kind):: acc + readlist=cnode_arg(cnode_arg(args,4),1) + i=1 + p=readlist + do + var=p%data%ptr(p%offset) + save_access(i)=get_access_info(var) + p=p%data%ptr(p%offset+1) + i=i+1 + enddo + call bprop_cblock(coder,cnode_arg(args,2),access_info,rvec) + i=1 + p=readlist + do + var=p%data%ptr(p%offset) + acc=access_info(cnode_get_num(var,var_index)) + call set_access_info(var,save_access(i)) + save_access(i)=acc + p=p%data%ptr(p%offset+1) + i=i+1 + enddo + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + i=1 + p=readlist + do + var=p%data%ptr(p%offset) + call combine_access_info(var,save_access(i)) + p=p%data%ptr(p%offset+1) + i=i+1 + enddo + end subroutine bprop_if + + subroutine bprop_proc_call + type(pm_ptr):: arg_access,key_access,key_names,proc_keys,arg,amps + integer:: i,j,nkeys,nproc_keys,taints + logical:: is_accessed, needs_to_run + + amps=cnode_get(callnode,call_amp) + taints=cnode_get_num(procnode,3) + + is_accessed=.false. + do i=1,nret + arg=cnode_arg(args,i) + is_accessed=is_accessed.or.accessed(arg) + call modify(arg) + enddo + if(.not.pm_fast_isnull(amps)) then + amps=pm_name_val(coder%context,int(amps%offset)) + do i=0,pm_fast_esize(amps) + arg=cnode_arg(args,amps%data%i(amps%offset+i)) + is_accessed=is_accessed.or.accessed(arg) + call modify(arg) + enddo + endif + + if(.not.is_accessed.and.iand(taints,proc_must_run)==0) then + call disable + return + endif + + arg_access=cnode_arg(procnode,6) + key_access=cnode_arg(procnode,7) + do i=1,nargs + call combine_access_info(cnode_arg(args,i),arg_access%data%i8(arg_access%offset+i-1)) + enddo + if(.not.pm_fast_isnull(cnode_get(callnode,call_keys))) then + nkeys=cnode_numargs(cnode_get(callnode,call_keys)) + key_names=pm_name_val(coder%context,cnode_get_num(callnode,call_key_names)) + proc_keys=cnode_get(cnode_arg(procnode,1),pr_keys) + nproc_keys=pm_fast_esize(proc_keys)/2 + outer: do j=1,nproc_keys + do i=1,nkeys + if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then + call combine_access_info(cnode_arg(args,i),key_access%data%i8(key_access%offset+j-1)) + cycle outer + endif + enddo + enddo outer + endif + + end subroutine bprop_proc_call + + subroutine std_access(always,start) + logical,intent(in):: always + integer,intent(in):: start + type(pm_ptr):: arg + integer:: i + logical:: is_accessed + is_accessed=.false. + do i=1,nret + arg=cnode_arg(args,i) + is_accessed=is_accessed.or.accessed(arg) + call modify(arg) + enddo + if(is_accessed.or.always) then + do i=1,nargs + call access(cnode_arg(args,i+nret)) + enddo + else + call disable + endif + do i=1,nargs + arg=cnode_arg(args,i+nret) + if(cnode_get_kind(arg)==cnode_is_cblock) then + call bprop_cblock(coder,arg,access_info,rvec) + endif + enddo + end subroutine std_access + + subroutine access(var) + type(pm_ptr):: var + integer:: idx + call combine_access_info(var,access_used_ever+access_used_now+access_is_var) + end subroutine access + + function accessed(var) result(ok) + type(pm_ptr):: var + logical:: ok + ok=iand(access_info(cnode_get_num(var,var_index)),access_used_now)/=0 + end function accessed + + subroutine modify(var) + type(pm_ptr):: var + integer:: idx + idx=cnode_get_num(var,var_index) + access_info(idx)=ior(access_is_var,& + iand(not(access_used_now),access_info(idx))) + end subroutine modify + + subroutine enable + access_info(cnode_get_num(callnode,call_index))=0 + end subroutine enable + + subroutine disable + access_info(cnode_get_num(callnode,call_index))=access_deactivated_call + end subroutine disable + + subroutine set_access_info(var,acc) + type(pm_ptr),intent(in):: var + integer(access_kind),intent(in):: acc + if(cnode_get_kind(var)==cnode_is_var) then + access_info(cnode_get_num(var,var_index))=acc + endif + end subroutine set_access_info + + subroutine combine_access_info(var,acc) + type(pm_ptr),intent(in):: var + integer(access_kind),intent(in):: acc + integer:: idx + if(cnode_get_kind(var)==cnode_is_var) then + idx=cnode_get_num(var,var_index) + access_info(idx)=ior(int(acc,access_kind),access_info(idx)) + endif + end subroutine combine_access_info + + function get_access_info(var) result(acc) + type(pm_ptr),intent(in):: var + integer(access_kind):: acc + if(cnode_get_kind(var)==cnode_is_var) then + acc=access_info(cnode_get_num(var,var_index)) + else + acc=0 + endif + end function get_access_info + + end subroutine bprop_call + !=================================================== ! Dump resolved proc signatures (debugging) !=================================================== diff --git a/src/parser.f90 b/src/parser.f90 index a5d6ee9..b90c070 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -1999,16 +1999,17 @@ recursive function term(parser,checkqual) result(iserr) if(expr(parser)) return if(expect(parser,sym_close)) return call make_node(parser,sym_dcaret,1) - case(sym_pm_dref:sym_pm_ref) + case(sym_pm_ref) call scan(parser) - if(expect(parser,sym_open)) return + if(parser%sym==sym_open) then + call push_sym_val(parser,0) + else + if(expect_name(parser)) return + if(expect(parser,sym_open)) return + endif if(exprlist(parser,m,nolist=.true.)) return if(expect(parser,sym_close)) return - if(m/=3) then - call parse_error(parser,'Wrong number of args to: '//sym_names(sym)) - return - endif - call make_node(parser,sym,m) + call make_node(parser,sym,m+1) case(sym_pm_each_index) call scan(parser) if(expect(parser,sym_open)) return diff --git a/src/types.f90 b/src/types.f90 index c2dd7e1..81e4797 100755 --- a/src/types.f90 +++ b/src/types.f90 @@ -1579,6 +1579,26 @@ recursive function pm_test_type_includes(context,supertype,subtype,& ok=.true. endif return + case(pm_type_is_dref) + if(tk==pm_type_is_dref) then + nt=pm_tv_name(t) + nu=pm_tv_name(u) + if(nt/=0.and.nt/=nu) then + ok=.false. + return + endif + do i=1,pm_tv_numargs(t) + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& + pm_tv_arg(u,i),mode,params,base,user,ubase)) then + ok=.false. + return + endif + enddo + ok=.true. + else + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) + endif case(pm_type_is_bottom) ok=.true. return @@ -1591,33 +1611,7 @@ recursive function pm_test_type_includes(context,supertype,subtype,& case(pm_type_is_basic) ok=.false. case(pm_type_is_dref) - if(tk/=uk) then - ok=.false. - return - endif - nt=pm_tv_name(t) - nu=pm_tv_name(u) - if(nt==pm_dref_is_any) then - if(nu/=pm_dref_is_any.and.iand(mode,pm_type_incl_type)/=0) then - ok=.true. - return - endif - elseif(.not.(nt==nu.or.& - (nt==pm_dref_is_dot.and.nu>0).or.& - (nt==pm_dref_is_any_slice.and.(nu==pm_dref_is_slice.or.& - nu==pm_dref_is_shared_slice)).or.& - nt==pm_dref_is_shared.and.nu==pm_dref_is_ref)) then - ok=.false. - return - endif - do i=1,pm_tv_numargs(t) - if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,params,base,user,ubase)) then - ok=.false. - return - endif - enddo - ok=.true. + ok=.false. case(pm_type_is_rec) if(tk/=uk) then ok=.false. @@ -2610,7 +2604,7 @@ recursive function pm_type_find_elem(context,value_type,name_type,change,etype) if(names%data%i(names%offset+offset)>0) offset=0 endif if(offset/=0) etype=pm_type_arg(context,tno,offset) - elseif(tk==pm_type_is_tuple) then + elseif(tk==pm_type_is_tuple.or.tk==pm_type_is_dref) then if(offset<=0.or.offset>pm_type_numargs(context,tno)) then offset=0 else diff --git a/src/vm.f90 b/src/vm.f90 index b8b49e3..2c4ff4d 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -63,6 +63,8 @@ subroutine pm_run_prog(context,funcs) integer:: err type(pm_ptr),dimension(1):: arg type(pm_ptr),target:: ve + + write(*,*) 'ext_mult=',pm_ext_mult,pm_jump_offset context%funcs=funcs @@ -1383,13 +1385,7 @@ recursive function pm_run(context,funcin,stackin,pcin,& v=pm_fast_newusr(context,& merge(pm_dref_type,pm_dref_shared_type,opcode2==0),& int(6,pm_p)) - if(nargs==5) then - v%data%ptr(v%offset+1:v%offset+3)=arg(3:5) - v%data%ptr(v%offset+4:v%offset+5)=& - arg(4)%data%ptr(arg(4)%offset+4:arg(4)%offset+5) - else - v%data%ptr(v%offset+1:v%offset+nargs-2)=arg(3:nargs) - endif + v%data%ptr(v%offset+1:v%offset+nargs-2)=arg(3:nargs) call set_arg(2,v) case(op_import_dref) call set_arg(2,& @@ -2502,6 +2498,9 @@ recursive function pm_run(context,funcin,stackin,pcin,& case(op_add_ln) esize=pm_fast_esize(arg(3)) if(esize/=pm_fast_esize(arg(4))) then + call pm_dump_tree(context,6,arg(3),2) + call pm_dump_tree(context,6,arg(4),2) + write(*,*) 'Internal error: import mismatch in op_add_ln' goto 999 endif diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 7e1884d..714635a 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -35,7 +35,7 @@ module pm_vmdefs integer,parameter:: pm_max_stack=2**14-1 - integer,parameter:: pm_ext_mult=2**15/(pm_max_stack+1) + integer,parameter:: pm_ext_mult=2**15/(pm_max_args+1) integer,parameter:: pm_jump_offset=pm_ext_mult*2**14 integer,parameter:: op_call=0 diff --git a/src/wcoder.f90 b/src/wcoder.f90 index d06c969..333543b 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -804,6 +804,8 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) break=.false. + if(rvv(cnode_get_num(callnode,call_index))==sp_sig_deactivated) return + args=cnode_get(callnode,call_args) nargs=cnode_numargs(args) nret=cnode_get_num(callnode,call_nret) @@ -1217,26 +1219,26 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc(wcd,-new_ve) break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) endif - case(sym_pm_dref:sym_pm_ref) + case(sym_pm_ref) if(pm_is_compiling) then - i=var_slot(wcd,cnode_arg(args,1)) - do ii=2,nargs - if(ii==4) then - slot=arg_slot(wcd,cnode_arg(args,ii)) - call cvar_set_ptr(wcd,i,ii-1,slot) - else - call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii-1),& - arg_slot(wcd,cnode_arg(args,ii))) - endif - enddo - j=var_slot(wcd,cnode_arg(args,3)) - do ii=nargs,5 - call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii),cvar_ptr(wcd,j,ii)) - enddo - call wc_call(wcd,callnode,op_dref,0,nargs,0,ve) - do ii=2,nargs - call wc_arg(wcd,cnode_arg(args,ii),.false.,rv,ve) - enddo +!!$ i=var_slot(wcd,cnode_arg(args,1)) +!!$ do ii=2,nargs +!!$ if(ii==4) then +!!$ slot=arg_slot(wcd,cnode_arg(args,ii)) +!!$ call cvar_set_ptr(wcd,i,ii-1,slot) +!!$ else +!!$ call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii-1),& +!!$ arg_slot(wcd,cnode_arg(args,ii))) +!!$ endif +!!$ enddo +!!$ j=var_slot(wcd,cnode_arg(args,3)) +!!$ do ii=nargs,5 +!!$ call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii),cvar_ptr(wcd,j,ii)) +!!$ enddo +!!$ call wc_call(wcd,callnode,op_dref,0,nargs,0,ve) +!!$ do ii=2,nargs +!!$ call wc_arg(wcd,cnode_arg(args,ii),.false.,rv,ve) +!!$ enddo else call wc_call_args(wcd,callnode,args,op_dref,& merge(0,1,sig==sym_pm_dref.or.sig==sym_pm_dref_slice),nargs,1,rv,ve) @@ -3729,6 +3731,10 @@ function alloc_var(wcd,typ) result(k) integer,intent(in):: typ integer:: i integer::k + if(typ==sp_sig_deactivated) then + k=-999 + return + endif if(pm_is_compiling) then k=cvar_alloc(wcd,typ,0) return From 34f35f4ed75127173deea28f933c5ef621ba6beb Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 14 Jul 2025 17:10:41 +0100 Subject: [PATCH 34/36] Backprop --- src/cnodes.f90 | 12 ++- src/infer.f90 | 197 ++++++++++++++++++++++++++++++++++--------------- src/parser.f90 | 2 + src/symbol.f90 | 6 +- 4 files changed, 154 insertions(+), 63 deletions(-) diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 5ecc558..89ae605 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -195,6 +195,7 @@ module pm_cnodes integer(access_kind),parameter:: access_is_var=1 integer(access_kind),parameter:: access_used_ever=2 integer(access_kind),parameter:: access_used_now=4 + integer(access_kind),parameter:: access_holds_result=8 integer(access_kind),parameter:: access_everything=& access_is_var+access_used_ever+access_used_now @@ -639,6 +640,9 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) elseif(k==sp_sig_noop) then str=repeat(' ',depth)//'call [noop]'//& pm_name_as_string(context,name) + elseif(k==sp_sig_deactivated) then + str=repeat(' ',depth)//'call [----]'//& + pm_name_as_string(context,name) elseif(k<0) then str=repeat(' ',depth)//'call '//'!![-'//trim(pm_int_as_string(-k))//']'& //pm_name_as_string(context,name) @@ -744,8 +748,12 @@ recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth, endif if(.not.pm_fast_isnull(rvec)) then tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) - call append_to_line(iunit,str,i,& - '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) + if(tno==sp_sig_deactivated) then + call append_to_line(iunit,str,i,'[----]',.false.,depth) + else + call append_to_line(iunit,str,i,& + '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) + endif endif if(cnode_flags_set(cnode,var_flags,var_is_maybe_not_private)) then call append_to_line(iunit,str,i,'^',.false.,depth) diff --git a/src/infer.f90 b/src/infer.f90 index d0a3555..7cfa7d2 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -75,7 +75,7 @@ module pm_infer !============================== subroutine inf_prog(coder) type(code_state),intent(inout):: coder - type(pm_ptr):: cnode + type(pm_ptr):: cnode,cblock integer:: i if(debug_inference) write(*,*) 'INF PROG>' @@ -97,7 +97,8 @@ subroutine inf_prog(coder) call create_stack_frame(coder,coder%index) ! Process program code - call inf_cblock(coder,top_code(coder)) + cblock=top_code(coder) + call inf_cblock(coder,cblock) ! Uncaught break implies infinite recursion if(coder%incomplete) then @@ -110,6 +111,9 @@ subroutine inf_prog(coder) endif endif + call bprop(coder,cblock,& + coder%stack(coder%base+1:coder%base+coder%index),.true.) + ! Create resolved code object call code_int_vec(coder,coder%stack,coder%base,coder%top) call code_num(coder,coder%stack(2)) @@ -150,7 +154,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& integer:: taints,save_taints,save_atype,save_new_atype,save_rtype,save_loop_depth integer:: keypartyp,keyargtyp,last_key_index,sp_code type(pm_ptr):: save_procnode,keys,keytypes - type(pm_ptr):: cached,cac,base_cache,rt_cache,at_cache + type(pm_ptr):: cached,cac,base_cache,rt_cache,at_cache,rvec logical:: ok,added,change_added,pushed_stack_frame,incomplete integer,dimension(3):: rtn_cache @@ -501,9 +505,13 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& return endif + write(*,*) 'TAINTS ARE', taints,coder%taints + ! Flag recursive calls with taints or keyword args as unfinished taints=iand(coder%taints,proc_taints) + write(*,*) 'AND THEN',taints + ! Determine a hash key with any polymorphic elements eliminated added=.false. base_key(1)=key(1) @@ -544,6 +552,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call code_num(coder,int(kk)) else call code_int_vec(coder,coder%stack,coder%base,coder%top) + rvec=top_code(coder) endif call code_num(coder,& ior(iand(cnode_get_num(procnode,pr_flags),& @@ -551,25 +560,41 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& coder%taints)) call code_num(coder,rtype) call code_num(coder,new_atype) - call make_code(coder,pm_null_obj,cnode_is_resolved_proc,5) + + write(*,*) '##~',coder%vtop + if(added) then + call bprop(coder,cnode_get(procnode,pr_cblock),& + coder%stack(coder%base+1:coder%base+cnode_get_num(procnode,pr_max_index)),& + .false.) + else + call bprop(coder,cnode_get(procnode,pr_cblock),& + rvec%data%i(rvec%offset+1:rvec%offset+cnode_get_num(procnode,pr_max_index)),& + .true.) + endif + write(*,*) '####~~~',coder%vtop + if(proc_nkeys==0) call code_null(coder) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,7) call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) call drop_code(coder) - + write(*,*) 'CODED',k call code_num(coder,int(k)) call pop_stack_frame(coder) call cnode_incr_num(procnode,pr_recurse,-1) call restore_proc_state - ! Pass out taint information - coder%proc_taints=iand(coder%taints,proc_taints) - coder%taints=ior(save_taints,coder%proc_taints) + - if(debug_inference) then + if(debug_inference.or..true.) then write(*,*) 'ENDPROCNODE>',trim(pm_name_as_string(coder%context,& - cnode_get_name(procnode,pr_name))),k + cnode_get_name(procnode,pr_name))),k,coder%taints endif + ! Pass out taint information + coder%proc_taints=iand(coder%taints,proc_taints) + coder%taints=ior(save_taints,coder%proc_taints) + + write(*,*) 'FINALLY',coder%taints contains include 'fnewnc.inc' include 'fistiny.inc' @@ -591,7 +616,7 @@ end subroutine save_proc_state subroutine restore_proc_state coder%incomplete=save_incomplete - coder%taints=save_taints + !coder%taints=save_taints coder%proc=save_procnode coder%atype=save_atype coder%new_atype=save_new_atype @@ -981,6 +1006,8 @@ function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype coder%proc_taints=iand(proc_taints,cnode_get_num(procnode,pr_flags)) coder%taints=ior(coder%taints,coder%proc_taints) + write(*,*) 'TAINTS',coder%taints,iand(coder%taints,proc_must_run) + return contains @@ -1073,6 +1100,7 @@ subroutine inf_cblock(coder,cblock) do while(.not.pm_fast_isnull(p)) call inf_call(coder,cblock,p) p=cnode_get(p,call_link) + write(*,*) 'TAINTS NOW',coder%taints enddo contains include 'fisnull.inc' @@ -3742,24 +3770,30 @@ subroutine make_type_if_possible(coder,n) end subroutine make_type_if_possible - subroutine bprop(coder,cblock,nargs,rvec,frame_size) + subroutine bprop(coder,cblock,rvec,update) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,rvec - integer,intent(in):: nargs,frame_size + type(pm_ptr),intent(in):: cblock + integer,dimension(:),intent(inout):: rvec + logical,intent(in):: update integer(access_kind),allocatable,dimension(:):: access_info integer:: save_loop_depth,i - allocate(access_info(frame_size)) + write(*,*) 'BP' + allocate(access_info(size(rvec))) access_info=0 save_loop_depth=coder%loop_depth call bprop_cblock(coder,cblock,access_info,rvec) coder%loop_depth=save_loop_depth - do i=1,frame_size - if(access_info(i)==access_deactivated_call.or.& - access_info(i)==access_is_var) then - rvec%data%i(rvec%offset)=sp_sig_deactivated - endif - end do - deallocate(access_info) + if(update) then + write(*,*) 'acc=',access_info + do i=1,size(rvec) + if(access_info(i)==access_deactivated_call.or.& + access_info(i)==access_is_var) then + write(*,*) 'Deactivate',i + rvec(i)=sp_sig_deactivated + endif + end do + deallocate(access_info) + endif end subroutine bprop @@ -3768,14 +3802,16 @@ end subroutine bprop !========================================== subroutine bprop_cblock(coder,cblock,access_info,rvec) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,rvec + type(pm_ptr),intent(in):: cblock + integer,dimension(:),intent(in)::rvec integer(access_kind),dimension(*),intent(inout):: access_info integer:: nvars,i,newbase type(pm_ptr):: p if(pm_fast_isnull(cblock)) return p=cnode_get(cblock,cblock_last_call) do while(.not.pm_fast_isnull(p)) - call inf_call(coder,cblock,p) + write(*,*) 'BPcall' + call bprop_call(coder,cblock,p,access_info,rvec) p=cnode_get(p,call_back_link) enddo contains @@ -3784,7 +3820,8 @@ end subroutine bprop_cblock subroutine bprop_call(coder,cblock,callnode,access_info,rvec) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,cblock,rvec + type(pm_ptr),intent(in):: callnode,cblock + integer,dimension(:),intent(in):: rvec integer(access_kind),dimension(*),intent(inout):: access_info type(pm_ptr):: args,arg,procnode integer:: nret,sig,nargs,opcode,i @@ -3794,8 +3831,10 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) nargs=cnode_numargs(args)-nret call enable if(sig>0) then + write(*,*) 'BPc ',sym_names(sig) select case(sig) case(sym_while,sym_while_invar) +!!! check whole loop (needs taints at block level) coder%loop_depth=coder%loop_depth+1 call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) call access(cnode_arg(args,2)) @@ -3806,6 +3845,7 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) endif case(sym_until,sym_until_invar) +!!! check whole loop (needs taints at block level) call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) call access(cnode_arg(args,2)) if(coder%loop_depth==1) then @@ -3814,15 +3854,18 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) endif case(sym_if,sym_if_invar) call bprop_if(count_updates(cnode_arg(args,4),1)) + case(sym_do) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) case(sym_task) - + case(sym_pm_ref) - call std_access(.true.,2) + call std_access(.false.,2) case(sym_open) call code_val(coder,pm_new(coder%context,access_pm_type,int(max(nargs,1),pm_ln))) arg=top_code(coder) do i=1,nargs arg%data%i8(arg%offset+i-1)=get_access_info(cnode_arg(args,i)) + write(*,*) 'store access',arg%data%i8(arg%offset+i-1) enddo case(sym_key) do i=2,nargs,2 @@ -3841,30 +3884,36 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) call set_access_info(cnode_arg(args,i),access_everything) enddo case default - call std_access(.true.,1) + call std_access(.false.,1) end select else - procnode=pm_dict_val(coder%context,coder%proc_cache,& - int(rvec%data%i(rvec%offset+cnode_get_num(callnode,call_index)),pm_ln)) - if(cnode_get_kind(procnode)==cnode_is_autoconv_sig) then - procnode=pm_dict_val(coder%context,coder%proc_cache,& - int(cnode_num_arg(procnode,cnode_numargs(procnode)),pm_ln)) - endif - if(cnode_get_kind(procnode)==cnode_is_resolved_proc) then - call bprop_proc_call + sig=rvec(cnode_get_num(callnode,call_index)) + if(sig<=0) then + call std_access(.false.,1) else - opcode=cnode_get_num(procnode,bi_opcode) - select case(opcode) - case(op_assign) - if(accessed(cnode_arg(args,2))) then - call access(cnode_arg(args,3)) - call modify(cnode_arg(args,2)) - else - call disable - endif - case default - call std_access(.true.,1) - end select + write(*,*) 'BPsig=',sig,trim(sig_name_str(coder,cnode_get_num(callnode,call_sig))) + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(sig,pm_ln)) + if(cnode_get_kind(procnode)==cnode_is_autoconv_sig) then + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(cnode_num_arg(procnode,cnode_numargs(procnode)),pm_ln)) + endif + if(cnode_get_kind(procnode)==cnode_is_resolved_proc) then + call bprop_proc_call + else + opcode=cnode_get_num(procnode,bi_opcode) + select case(opcode) + case(op_assign) + if(accessed(cnode_arg(args,2))) then + call access(cnode_arg(args,3)) + call modify(cnode_arg(args,2)) + else + call disable + endif + case default + call std_access(iand(cnode_get_num(procnode,pr_flags),proc_must_run)/=0,1) + end select + endif endif endif contains @@ -3912,34 +3961,55 @@ end subroutine bprop_if subroutine bprop_proc_call type(pm_ptr):: arg_access,key_access,key_names,proc_keys,arg,amps integer:: i,j,nkeys,nproc_keys,taints - logical:: is_accessed, needs_to_run + logical:: arg_accessed,is_accessed, all_accessed, needs_to_run amps=cnode_get(callnode,call_amp) - taints=cnode_get_num(procnode,3) + taints=cnode_num_arg(procnode,3) + + write(*,*) 'BPcall',iand(taints,proc_must_run) is_accessed=.false. + all_accessed=.true. do i=1,nret arg=cnode_arg(args,i) - is_accessed=is_accessed.or.accessed(arg) + arg_accessed=accessed(arg) + is_accessed=is_accessed.or.arg_accessed + all_accessed=all_accessed.and.arg_accessed call modify(arg) enddo if(.not.pm_fast_isnull(amps)) then amps=pm_name_val(coder%context,int(amps%offset)) do i=0,pm_fast_esize(amps) arg=cnode_arg(args,amps%data%i(amps%offset+i)) - is_accessed=is_accessed.or.accessed(arg) + arg_accessed=accessed(arg) + is_accessed=is_accessed.or.arg_accessed + all_accessed=all_accessed.and.arg_accessed call modify(arg) enddo endif - + if(.not.is_accessed.and.iand(taints,proc_must_run)==0) then + write(*,*) 'disable',is_accessed,iand(taints,proc_must_run) call disable return endif - + + if(.not.all_accessed) then + do i=1,nret + call combine_access_info(cnode_arg(args,i),access_holds_result) + enddo + if(.not.pm_fast_isnull(amps)) then + do i=0,pm_fast_esize(amps) + arg=cnode_arg(args,amps%data%i(amps%offset+i)) + call combine_access_info(arg,access_holds_result) + enddo + endif + endif + arg_access=cnode_arg(procnode,6) key_access=cnode_arg(procnode,7) do i=1,nargs + write(*,*) 'Combine #',i,'with',arg_access%data%i8(arg_access%offset+i-1) call combine_access_info(cnode_arg(args,i),arg_access%data%i8(arg_access%offset+i-1)) enddo if(.not.pm_fast_isnull(cnode_get(callnode,call_keys))) then @@ -3964,23 +4034,32 @@ subroutine std_access(always,start) integer,intent(in):: start type(pm_ptr):: arg integer:: i - logical:: is_accessed + logical:: arg_accessed,is_accessed,all_accessed is_accessed=.false. + all_accessed=.true. do i=1,nret arg=cnode_arg(args,i) - is_accessed=is_accessed.or.accessed(arg) + arg_accessed=accessed(arg) + is_accessed=is_accessed.or.arg_accessed + all_accessed=all_accessed.and.arg_accessed call modify(arg) enddo if(is_accessed.or.always) then do i=1,nargs call access(cnode_arg(args,i+nret)) enddo + if(.not.all_accessed) then + do i=1,nret + call combine_access_info(cnode_arg(args,i),access_holds_result) + enddo + endif else call disable endif do i=1,nargs arg=cnode_arg(args,i+nret) if(cnode_get_kind(arg)==cnode_is_cblock) then + write(*,*) 'SUBBLOCK' call bprop_cblock(coder,arg,access_info,rvec) endif enddo @@ -3991,13 +4070,13 @@ subroutine access(var) integer:: idx call combine_access_info(var,access_used_ever+access_used_now+access_is_var) end subroutine access - + function accessed(var) result(ok) type(pm_ptr):: var logical:: ok ok=iand(access_info(cnode_get_num(var,var_index)),access_used_now)/=0 end function accessed - + subroutine modify(var) type(pm_ptr):: var integer:: idx @@ -4009,7 +4088,7 @@ end subroutine modify subroutine enable access_info(cnode_get_num(callnode,call_index))=0 end subroutine enable - + subroutine disable access_info(cnode_get_num(callnode,call_index))=access_deactivated_call end subroutine disable diff --git a/src/parser.f90 b/src/parser.f90 index b90c070..de47a2f 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -5358,6 +5358,8 @@ function builtin_flags(parser,flags) result(iserr) flags=ior(flags,proc_is_not_inlinable) case(sym_proc_needs_type) flags=ior(flags,proc_needs_type) + case(sym_proc_prints_out) + flags=ior(flags,proc_prints_out) case default call parse_error(parser,'Bad PM__intrinsic attribute') return diff --git a/src/symbol.f90 b/src/symbol.f90 index ad2faa1..0b9528d 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -283,12 +283,13 @@ module pm_symbol integer,parameter:: sym_proc_is_file = num_sym + 23 integer,parameter:: sym_proc_is_not_inlinable = num_sym + 24 integer,parameter:: sym_proc_needs_type = num_sym + 25 + integer,parameter:: sym_proc_prints_out = num_sym + 26 ! Specialised types - integer,parameter:: sym_literal = num_sym + 26 + integer,parameter:: sym_literal = num_sym + 27 ! Symbols used as node types (actual name not really used) - integer,parameter:: node0 = num_sym + 26 + integer,parameter:: node0 = num_sym + 27 integer,parameter:: sym_iter = node0 + 1 integer,parameter:: sym_list = node0 + 2 integer,parameter:: sym_builtin = node0 + 3 @@ -762,6 +763,7 @@ module pm_symbol data sym_names(sym_proc_is_file) /'is_file'/ data sym_names(sym_proc_is_not_inlinable) /'is_not_inlinable'/ data sym_names(sym_proc_needs_type) /'needs_type'/ + data sym_names(sym_proc_prints_out) /'prints_out'/ data sym_names(sym_literal) /'literal'/ From 8b8d7a455f331a6d6ef8122b493d2128710408a4 Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Fri, 18 Jul 2025 14:59:08 +0100 Subject: [PATCH 35/36] Backpropagation phase --- lib/sys/pm.pmm | 2 +- pm/Makefile | 2 +- src/cnodes.f90 | 33 +++-- src/infer.f90 | 336 ++++++++++++++++++++++++++++++++----------------- src/vm.f90 | 4 +- src/wcoder.f90 | 35 +++--- 6 files changed, 264 insertions(+), 148 deletions(-) diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm index 2511159..ef3a7b9 100644 --- a/lib/sys/pm.pmm +++ b/lib/sys/pm.pmm @@ -98,7 +98,7 @@ PM__intrinsic ++(fix(string),fix(string))->(fix(string)) : "concat_fold" // ************************************** // String type -PM__intrinsic<> print(string): "print" +PM__intrinsic<> print(string): "print" proc print(x) { print(string(x)) diff --git a/pm/Makefile b/pm/Makefile index 4d85d10..aed0496 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -98,7 +98,7 @@ infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o vmdefs.o types.o li wcoder.o : ../src/wcoder.f90 array.o infer.o cnodes.o ast.o symbol.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -vm.o : ../src/vm.f90 parlib.o array.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +vm.o : ../src/vm.f90 parlib.o array.o types.o symbol.o lib.o vmdefs.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< main.o : ../src/main.f90 vm.o parlib.o array.o wcoder.o infer.o codegen.o linker.o parser.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 89ae605..5eec820 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -601,8 +601,15 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) type(pm_ptr):: p,args,amps,keys,keynames character(len=120):: str,location signo=cnode_get_num(cnode,call_sig) + str=' ' + if(.not.pm_fast_isnull(rvec)) then + k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) + if(k==sp_sig_deactivated) then + str='[--]' + endif + endif if(signo<0) then - str=repeat(' ',depth)//pm_name_as_string(context,-signo) + str=repeat(' ',depth)//trim(str)//pm_name_as_string(context,-signo) i=len_trim(str)+1 if(.not.pm_fast_isnull(rvec)) then k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) @@ -612,7 +619,7 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) endif endif elseif(signo==0) then - str=repeat(' ',depth)//'var-call' + str=repeat(' ',depth)//trim(str)//'var-call' i=len_trim(str)+1 call print_value_cnode(context,iunit,rvec,sig_cache,& cnode_get(cnode,call_var),depth,str,i) @@ -622,32 +629,32 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) int(signo,pm_ln)) name=p%data%i(p%offset+pm_fast_esize(p)) if(.not.pm_fast_isnull(cnode_get(cnode,call_var))) then - str=repeat(' ',depth)//'call *(' + str=repeat(' ',depth)//trim(str)//'call *(' i=depth+7 call print_value_cnode(context,iunit,rvec,sig_cache,& cnode_get(cnode,call_var),depth,str,i) call append_to_line(iunit,str,i,') ',.false.,depth) elseif(pm_fast_isnull(rvec)) then - str=repeat(' ',depth)//'call '//pm_name_as_string(context,name) + str=repeat(' ',depth)//trim(str)//'call '//pm_name_as_string(context,name) else k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) if(k==sp_sig_link) then - str=repeat(' ',depth)//'call [link]'//& + str=trim(str)//repeat(' ',depth)//trim(str)//'call [link]'//& pm_name_as_string(context,name) elseif(k==sp_sig_dup) then - str=repeat(' ',depth)//'call [dup]'//& + str=repeat(' ',depth)//trim(str)//'call [dup]'//& pm_name_as_string(context,name) elseif(k==sp_sig_noop) then - str=repeat(' ',depth)//'call [noop]'//& + str=repeat(' ',depth)//trim(str)//'call [noop]'//& pm_name_as_string(context,name) elseif(k==sp_sig_deactivated) then - str=repeat(' ',depth)//'call [----]'//& + str=repeat(' ',depth)//trim(str)//'call '//& pm_name_as_string(context,name) elseif(k<0) then - str=repeat(' ',depth)//'call '//'!![-'//trim(pm_int_as_string(-k))//']'& + str=repeat(' ',depth)//trim(str)//'call '//'!![-'//trim(pm_int_as_string(-k))//']'& //pm_name_as_string(context,name) else - str=repeat(' ',depth)//'call '//'['//trim(pm_int_as_string(k))//']'& + str=repeat(' ',depth)//trim(str)//'call '//'['//trim(pm_int_as_string(k))//']'& //pm_name_as_string(context,name) endif endif @@ -700,6 +707,10 @@ recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) modl=cnode_get_num(cnode,cnode_modl_name) line=cnode_get_num(cnode,cnode_lineno) location=trim(pm_name_as_string(context,modl))//':'//pm_int_as_string(line) + if(i>len(str)-len_trim(location)) then + write(iunit,'(a)') str + str=' ' + endif str(len(str)-len_trim(location)+1:)=location write(iunit,'(a)') str @@ -749,7 +760,7 @@ recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth, if(.not.pm_fast_isnull(rvec)) then tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) if(tno==sp_sig_deactivated) then - call append_to_line(iunit,str,i,'[----]',.false.,depth) + call append_to_line(iunit,str,i,'[---]',.false.,depth) else call append_to_line(iunit,str,i,& '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) diff --git a/src/infer.f90 b/src/infer.f90 index 7cfa7d2..cbd3a3c 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -51,6 +51,7 @@ module pm_infer ! Print compiler debugging messages logical,parameter:: debug_inference=.false. + logical,parameter:: debug_bprop=.false. ! Maximum times a procedure template can call itself with ! *different* arguments types each time @@ -505,13 +506,9 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& return endif - write(*,*) 'TAINTS ARE', taints,coder%taints - ! Flag recursive calls with taints or keyword args as unfinished taints=iand(coder%taints,proc_taints) - write(*,*) 'AND THEN',taints - ! Determine a hash key with any polymorphic elements eliminated added=.false. base_key(1)=key(1) @@ -561,7 +558,6 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call code_num(coder,rtype) call code_num(coder,new_atype) - write(*,*) '##~',coder%vtop if(added) then call bprop(coder,cnode_get(procnode,pr_cblock),& coder%stack(coder%base+1:coder%base+cnode_get_num(procnode,pr_max_index)),& @@ -571,12 +567,10 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& rvec%data%i(rvec%offset+1:rvec%offset+cnode_get_num(procnode,pr_max_index)),& .true.) endif - write(*,*) '####~~~',coder%vtop if(proc_nkeys==0) call code_null(coder) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,7) call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) call drop_code(coder) - write(*,*) 'CODED',k call code_num(coder,int(k)) call pop_stack_frame(coder) call cnode_incr_num(procnode,pr_recurse,-1) @@ -585,7 +579,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& - if(debug_inference.or..true.) then + if(debug_inference) then write(*,*) 'ENDPROCNODE>',trim(pm_name_as_string(coder%context,& cnode_get_name(procnode,pr_name))),k,coder%taints endif @@ -594,7 +588,6 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& coder%proc_taints=iand(coder%taints,proc_taints) coder%taints=ior(save_taints,coder%proc_taints) - write(*,*) 'FINALLY',coder%taints contains include 'fnewnc.inc' include 'fistiny.inc' @@ -1005,9 +998,6 @@ function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype ! Pass out taint information coder%proc_taints=iand(proc_taints,cnode_get_num(procnode,pr_flags)) coder%taints=ior(coder%taints,coder%proc_taints) - - write(*,*) 'TAINTS',coder%taints,iand(coder%taints,proc_must_run) - return contains @@ -1093,19 +1083,33 @@ end function inf_builtin subroutine inf_cblock(coder,cblock) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock - integer:: nvars,i,newbase + integer:: save_taints type(pm_ptr):: p if(pm_fast_isnull(cblock)) return + save_taints=coder%taints + coder%taints=0 p=cnode_get(cblock,cblock_first_call) do while(.not.pm_fast_isnull(p)) call inf_call(coder,cblock,p) p=cnode_get(p,call_link) - write(*,*) 'TAINTS NOW',coder%taints enddo + coder%stack(coder%base+cnode_get_num(cblock,cblock_index))=coder%taints + coder%taints=ior(save_taints,coder%taints) contains include 'fisnull.inc' end subroutine inf_cblock + !========================================== + ! Return tainta associated with a block + ! - inference on block must be complete + !========================================== + function cblock_taints(coder,cblock) result(taints) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock + integer:: taints + taints=coder%stack(coder%base+cnode_get_num(cblock,cblock_index)) + end function cblock_taints + !======================================================= ! Type infer general calls ! (which include control structures as a special case) @@ -1999,20 +2003,6 @@ subroutine check_loop_writes(arg) enddo end subroutine check_loop_writes - subroutine clear_cblock_mark(list) - type(pm_ptr),intent(in):: list - integer:: slot - slot=coder%base+cnode_get_num(list,cblock_index) - coder%stack(slot)=0 - end subroutine clear_cblock_mark - - function cblock_marked(list) result(marked) - type(pm_ptr),intent(in):: list - logical:: marked - integer:: slot - slot=coder%base+cnode_get_num(list,cblock_index) - marked=coder%stack(slot)/=0 - end function cblock_marked !================================================================== ! Flag if an import or export option actually @@ -3777,18 +3767,21 @@ subroutine bprop(coder,cblock,rvec,update) logical,intent(in):: update integer(access_kind),allocatable,dimension(:):: access_info integer:: save_loop_depth,i - write(*,*) 'BP' - allocate(access_info(size(rvec))) + if(debug_bprop) then + write(*,*) 'BP' + endif + allocate(access_info(size(rvec)+pm_max_args)) access_info=0 save_loop_depth=coder%loop_depth call bprop_cblock(coder,cblock,access_info,rvec) coder%loop_depth=save_loop_depth if(update) then - write(*,*) 'acc=',access_info do i=1,size(rvec) if(access_info(i)==access_deactivated_call.or.& access_info(i)==access_is_var) then - write(*,*) 'Deactivate',i + if(debug_bprop) then + write(*,*) 'BP Deactivate',i + endif rvec(i)=sp_sig_deactivated endif end do @@ -3805,12 +3798,17 @@ subroutine bprop_cblock(coder,cblock,access_info,rvec) type(pm_ptr),intent(in):: cblock integer,dimension(:),intent(in)::rvec integer(access_kind),dimension(*),intent(inout):: access_info - integer:: nvars,i,newbase + integer:: nvars,idx,newbase type(pm_ptr):: p if(pm_fast_isnull(cblock)) return + p=cnode_get(cblock,cblock_first_var) + do while(.not.pm_fast_isnull(p)) + idx=cnode_get_num(p,var_index) + access_info(idx)=ior(access_info(idx),access_is_var) + p=cnode_get(p,var_link) + enddo p=cnode_get(cblock,cblock_last_call) do while(.not.pm_fast_isnull(p)) - write(*,*) 'BPcall' call bprop_call(coder,cblock,p,access_info,rvec) p=cnode_get(p,call_back_link) enddo @@ -3823,35 +3821,54 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) type(pm_ptr),intent(in):: callnode,cblock integer,dimension(:),intent(in):: rvec integer(access_kind),dimension(*),intent(inout):: access_info - type(pm_ptr):: args,arg,procnode - integer:: nret,sig,nargs,opcode,i + type(pm_ptr):: args,arg,tv + integer:: nret,nargs,nvargs,opcode,i,sig,tno nret=cnode_get_num(callnode,call_nret) sig=-cnode_get_num(callnode,call_sig) args=cnode_get(callnode,call_args) nargs=cnode_numargs(args)-nret call enable if(sig>0) then - write(*,*) 'BPc ',sym_names(sig) + if(debug_bprop) then + write(*,*) 'BPcall ',sym_names(sig) + endif select case(sig) case(sym_while,sym_while_invar) -!!! check whole loop (needs taints at block level) - coder%loop_depth=coder%loop_depth+1 - call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) - call access(cnode_arg(args,2)) - call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) - if(coder%loop_depth==1) then - call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + if(cblock_must_run(cnode_arg(args,1)).or.cblock_must_run(cnode_arg(args,3)) & + .or.block_writes_accessed(4)) then + coder%loop_depth=coder%loop_depth+1 call access(cnode_arg(args,2)) call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) - endif - case(sym_until,sym_until_invar) -!!! check whole loop (needs taints at block level) - call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) - call access(cnode_arg(args,2)) - if(coder%loop_depth==1) then - call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + if(coder%loop_depth==1) then + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + endif + else + if(debug_bprop) then + write(*,*) 'DISABLE while' + endif + call disable endif + case(sym_until,sym_until_invar) + if(cblock_must_run(cnode_arg(args,1)).or.& + block_writes_accessed(3)) then + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + if(coder%loop_depth==1) then + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + endif + else + if(debug_bprop) then + write(*,*) 'DISABLE until' + endif + call disable + endif case(sym_if,sym_if_invar) call bprop_if(count_updates(cnode_arg(args,4),1)) case(sym_do) @@ -3861,11 +3878,32 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) case(sym_pm_ref) call std_access(.false.,2) case(sym_open) - call code_val(coder,pm_new(coder%context,access_pm_type,int(max(nargs,1),pm_ln))) + arg=cnode_arg(args,nargs) + nvargs=0 + if(cnode_get_kind(arg)==cnode_is_var) then + if(cnode_flags_set(arg,var_flags,var_is_varg)) then + tno=rvec(cnode_get_num(arg,var_index)) + if(tno>0) then + tv=pm_type_vect(coder%context,tno) + if(pm_tv_kind(tv)==pm_type_is_tuple.and.& + iand(pm_tv_flags(tv),pm_type_is_list)==0) then + nvargs=pm_tv_numargs(tv) + call combine_access_info(arg,access_holds_result) + endif + endif + endif + endif + call code_val(coder,pm_new(coder%context,& + access_pm_type,int(max(nargs+nvargs,1),pm_ln))) arg=top_code(coder) do i=1,nargs arg%data%i8(arg%offset+i-1)=get_access_info(cnode_arg(args,i)) - write(*,*) 'store access',arg%data%i8(arg%offset+i-1) + if(debug_bprop) then + write(*,*) 'BP store access',arg%data%i8(arg%offset+i-1),cnode_get_num(cnode_arg(args,i),var_index) + endif + enddo + do i=1,nvargs-1 + arg%data%i8(arg%offset+i+nargs-1)=access_info(size(rvec)+i) enddo case(sym_key) do i=2,nargs,2 @@ -3887,39 +3925,13 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) call std_access(.false.,1) end select else - sig=rvec(cnode_get_num(callnode,call_index)) - if(sig<=0) then - call std_access(.false.,1) - else - write(*,*) 'BPsig=',sig,trim(sig_name_str(coder,cnode_get_num(callnode,call_sig))) - procnode=pm_dict_val(coder%context,coder%proc_cache,& - int(sig,pm_ln)) - if(cnode_get_kind(procnode)==cnode_is_autoconv_sig) then - procnode=pm_dict_val(coder%context,coder%proc_cache,& - int(cnode_num_arg(procnode,cnode_numargs(procnode)),pm_ln)) - endif - if(cnode_get_kind(procnode)==cnode_is_resolved_proc) then - call bprop_proc_call - else - opcode=cnode_get_num(procnode,bi_opcode) - select case(opcode) - case(op_assign) - if(accessed(cnode_arg(args,2))) then - call access(cnode_arg(args,3)) - call modify(cnode_arg(args,2)) - else - call disable - endif - case default - call std_access(iand(cnode_get_num(procnode,pr_flags),proc_must_run)/=0,1) - end select - endif - endif + call bprop_proc_call endif contains include 'fesize.inc' include 'fisnull.inc' + include 'fvkind.inc' subroutine bprop_if(nupdates) integer:: nupdates @@ -3927,10 +3939,17 @@ subroutine bprop_if(nupdates) integer(access_kind),dimension(nupdates):: save_access integer:: i integer(access_kind):: acc + + if(.not.(block_writes_accessed(4).or.cblock_must_run(cnode_arg(args,2)).or.& + cblock_must_run(cnode_arg(args,3)))) then + call disable + return + endif + readlist=cnode_arg(cnode_arg(args,4),1) i=1 p=readlist - do + do while(.not.pm_fast_isnull(p)) var=p%data%ptr(p%offset) save_access(i)=get_access_info(var) p=p%data%ptr(p%offset+1) @@ -3939,7 +3958,7 @@ subroutine bprop_if(nupdates) call bprop_cblock(coder,cnode_arg(args,2),access_info,rvec) i=1 p=readlist - do + do while(.not.pm_fast_isnull(p)) var=p%data%ptr(p%offset) acc=access_info(cnode_get_num(var,var_index)) call set_access_info(var,save_access(i)) @@ -3950,37 +3969,74 @@ subroutine bprop_if(nupdates) call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) i=1 p=readlist - do + do while(.not.pm_fast_isnull(p)) var=p%data%ptr(p%offset) call combine_access_info(var,save_access(i)) p=p%data%ptr(p%offset+1) i=i+1 enddo + call access(cnode_arg(args,1)) end subroutine bprop_if subroutine bprop_proc_call - type(pm_ptr):: arg_access,key_access,key_names,proc_keys,arg,amps - integer:: i,j,nkeys,nproc_keys,taints - logical:: arg_accessed,is_accessed, all_accessed, needs_to_run + type(pm_ptr):: arg_access,key_access,key_names,proc_keys,arg,amps,key_args,procnode + integer:: i,j,nkeys,nproc_keys,taints,sig + logical:: arg_accessed,is_accessed, all_accessed, needs_to_run, is_builtin + sig=rvec(cnode_get_num(callnode,call_index)) + if(sig<=0) then + call std_access(.false.,1) + return + endif + amps=cnode_get(callnode,call_amp) - taints=cnode_num_arg(procnode,3) - write(*,*) 'BPcall',iand(taints,proc_must_run) - + if(debug_bprop) then + write(*,*) 'BPsig=',sig,trim(sig_name_str(coder,cnode_get_num(callnode,call_sig))) + endif + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(sig,pm_ln)) + + if(pm_fast_vkind(procnode)/=pm_pointer) then + ! Recursive call + call std_access(.false.,1) + return + endif + + if(cnode_get_kind(procnode)==cnode_is_autoconv_sig) then + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(cnode_num_arg(procnode,cnode_numargs(procnode)),pm_ln)) + endif + + is_builtin=cnode_get_kind(procnode)==cnode_is_builtin + + if(is_builtin) then + taints=cnode_get_num(procnode,pr_flags) + else + taints=cnode_num_arg(procnode,3) + endif + + if(debug_bprop) then + write(*,*) 'BPcall taints=',iand(taints,proc_must_run) + endif + is_accessed=.false. all_accessed=.true. do i=1,nret arg=cnode_arg(args,i) arg_accessed=accessed(arg) + if(debug_bprop) then + write(*,*) 'accessed #',i,cnode_get_num(arg,var_index),arg_accessed + endif is_accessed=is_accessed.or.arg_accessed all_accessed=all_accessed.and.arg_accessed call modify(arg) enddo + if(.not.pm_fast_isnull(amps)) then amps=pm_name_val(coder%context,int(amps%offset)) do i=0,pm_fast_esize(amps) - arg=cnode_arg(args,amps%data%i(amps%offset+i)) + arg=cnode_arg(args,nret+amps%data%i(amps%offset+i)) arg_accessed=accessed(arg) is_accessed=is_accessed.or.arg_accessed all_accessed=all_accessed.and.arg_accessed @@ -3988,8 +4044,12 @@ subroutine bprop_proc_call enddo endif + if(debug_bprop) then + write(*,*) 'BPa',is_accessed,all_accessed + endif + if(.not.is_accessed.and.iand(taints,proc_must_run)==0) then - write(*,*) 'disable',is_accessed,iand(taints,proc_must_run) + if(debug_bprop) write(*,*) 'BP disable',is_accessed,iand(taints,proc_must_run) call disable return endif @@ -4000,31 +4060,44 @@ subroutine bprop_proc_call enddo if(.not.pm_fast_isnull(amps)) then do i=0,pm_fast_esize(amps) - arg=cnode_arg(args,amps%data%i(amps%offset+i)) + arg=cnode_arg(args,nret+amps%data%i(amps%offset+i)) call combine_access_info(arg,access_holds_result) enddo endif endif - arg_access=cnode_arg(procnode,6) - key_access=cnode_arg(procnode,7) - do i=1,nargs - write(*,*) 'Combine #',i,'with',arg_access%data%i8(arg_access%offset+i-1) - call combine_access_info(cnode_arg(args,i),arg_access%data%i8(arg_access%offset+i-1)) - enddo - if(.not.pm_fast_isnull(cnode_get(callnode,call_keys))) then - nkeys=cnode_numargs(cnode_get(callnode,call_keys)) - key_names=pm_name_val(coder%context,cnode_get_num(callnode,call_key_names)) - proc_keys=cnode_get(cnode_arg(procnode,1),pr_keys) - nproc_keys=pm_fast_esize(proc_keys)/2 - outer: do j=1,nproc_keys - do i=1,nkeys - if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then - call combine_access_info(cnode_arg(args,i),key_access%data%i8(key_access%offset+j-1)) - cycle outer - endif - enddo - enddo outer + if(is_builtin) then + do i=1,nargs + call access(cnode_arg(args,nret+i)) + enddo + else + arg_access=cnode_arg(procnode,6) + key_access=cnode_arg(procnode,7) + do i=1,nargs + !!$ write(*,*) 'Combine #',i,cnode_get_num(cnode_arg(args,i+nret),var_index),'with',arg_access%data%i8(arg_access%offset+i-1) + !!! Need to cater for vargs + call combine_access_info(cnode_arg(args,i+nret),& + arg_access%data%i8(arg_access%offset+i-1)) + enddo + do i=nargs+1,pm_fast_esize(arg_access)+1 + j=size(rvec)+i-nargs + access_info(j)=ior(access_info(j),arg_access%data%i8(arg_access%offset+i-1)) + enddo + if(.not.pm_fast_isnull(cnode_get(callnode,call_keys))) then + nkeys=cnode_numargs(cnode_get(callnode,call_keys)) + key_names=pm_name_val(coder%context,cnode_get_num(callnode,call_key_names)) + proc_keys=cnode_get(cnode_arg(procnode,1),pr_keys) + nproc_keys=pm_fast_esize(proc_keys)/2 + key_args=cnode_get(callnode,call_keys) + outer: do j=1,nproc_keys + do i=1,nkeys + if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then + call combine_access_info(cnode_arg(key_args,i),key_access%data%i8(key_access%offset+j-1)) + cycle outer + endif + enddo + enddo outer + endif endif end subroutine bprop_proc_call @@ -4034,7 +4107,8 @@ subroutine std_access(always,start) integer,intent(in):: start type(pm_ptr):: arg integer:: i - logical:: arg_accessed,is_accessed,all_accessed + logical:: arg_accessed,is_accessed,all_accessed,should_disable + should_disable=.false. is_accessed=.false. all_accessed=.true. do i=1,nret @@ -4054,27 +4128,37 @@ subroutine std_access(always,start) enddo endif else - call disable + should_disable=.true. endif do i=1,nargs arg=cnode_arg(args,i+nret) if(cnode_get_kind(arg)==cnode_is_cblock) then - write(*,*) 'SUBBLOCK' call bprop_cblock(coder,arg,access_info,rvec) + should_disable=.false. endif enddo + if(should_disable) call disable end subroutine std_access subroutine access(var) type(pm_ptr):: var integer:: idx + if(debug_bprop) then + if(cnode_get_kind(var)==cnode_is_var) then + write(*,*) 'Make access to',cnode_get_num(var,var_index) + endif + endif call combine_access_info(var,access_used_ever+access_used_now+access_is_var) end subroutine access function accessed(var) result(ok) type(pm_ptr):: var logical:: ok - ok=iand(access_info(cnode_get_num(var,var_index)),access_used_now)/=0 + if(cnode_get_kind(var)==cnode_is_var) then + ok=iand(access_info(cnode_get_num(var,var_index)),access_used_now)/=0 + else + ok=.true. + endif end function accessed subroutine modify(var) @@ -4121,6 +4205,26 @@ function get_access_info(var) result(acc) endif end function get_access_info + function cblock_must_run(cblock) result(ok) + type(pm_ptr),intent(in):: cblock + logical:: ok + ok=iand(cblock_taints(coder,cblock),proc_must_run)/=0 + end function cblock_must_run + + function block_writes_accessed(n) result(is_accessed) + integer,intent(in):: n + logical:: is_accessed + type(pm_ptr):: writelist,p,var + writelist=cnode_arg(cnode_arg(args,n),2) + p=writelist + is_accessed=.false. + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + is_accessed=is_accessed.or.accessed(var) + p=p%data%ptr(p%offset+1) + enddo + end function block_writes_accessed + end subroutine bprop_call !=================================================== diff --git a/src/vm.f90 b/src/vm.f90 index 2c4ff4d..8fc4299 100755 --- a/src/vm.f90 +++ b/src/vm.f90 @@ -63,9 +63,7 @@ subroutine pm_run_prog(context,funcs) integer:: err type(pm_ptr),dimension(1):: arg type(pm_ptr),target:: ve - - write(*,*) 'ext_mult=',pm_ext_mult,pm_jump_offset - + context%funcs=funcs ! Create intial vector engine structure diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 333543b..aa0d9a0 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -503,7 +503,7 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) type(pm_ptr),intent(out):: pp integer:: npar type(pm_ptr):: p,tv - integer:: slot,i + integer:: slot,i,rslot integer:: v,xpar integer:: typ logical:: isref,isshared @@ -521,11 +521,11 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) write(*,*) 'ALLOCATING PARAM>',& trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))) endif - wcd%rdata(slot+wcd%base)=alloc_param_var(wcd,& + rslot=alloc_param_var(wcd,& typ,isref,.false.,cnode_get_num(p,var_name)) if(debug_wcode) write(*,*) 'TO>',wcd%rdata(slot+wcd%base) - - npar=npar+1 + wcd%rdata(slot+wcd%base)=rslot + if(rslot/=0) npar=npar+1 p=cnode_get(p,var_link) if(pm_fast_isnull(p)) exit enddo @@ -627,8 +627,9 @@ subroutine push_costate(wcd,cblock,p,first_pc,num_named,rv,ve) cs=wcd%cs top=wcd%cotop(cs)+1 wcd%cotop(cs)=top - if(top>max_costack) & - call pm_panic('Program too complex') + if(top>max_costack) then + call pm_panic('Program too complex - costack full') + endif wcd%costack(cs,top)%cblock=cblock wcd%costack(cs,top)%p=p wcd%costack(cs,top)%first_pc=first_pc @@ -718,7 +719,7 @@ function wcode_mvars(wcd,cblock,rv,ve,pp) result(num_named) slot=cnode_get_num(p,var_index) nam=cnode_get(p,var_name) wcd%rdata(slot+wcd%base)=alloc_general_var(wcd,p,rv) - if(cnode_get_num(p,var_name)/=0.or.pm_is_compiling) & + if(slot/=0.and.cnode_get_num(p,var_name)/=0.or.pm_is_compiling) & num_named=num_named+1 endif p=cnode_get(p,var_link) @@ -737,7 +738,7 @@ subroutine close_vars(wcd,cblock,rv,ve,first_pc,nvars,pp) integer,intent(in):: first_pc,nvars type(pm_ptr),optional,intent(in):: pp type(pm_ptr):: p - integer:: slot,j + integer:: slot,rslot,j integer:: name ! Info entry for parameters & named multi-use variables @@ -761,11 +762,12 @@ subroutine close_vars(wcd,cblock,rv,ve,first_pc,nvars,pp) if(arg_is_mvar(p).or.cnode_flags_set(p,var_flags,var_is_param)) then slot=cnode_get_num(p,var_index) if(.not.pm_is_compiling) then - call release_var(wcd,wcd%rdata(slot+wcd%base)) + rslot=wcd%rdata(slot+wcd%base) + call release_var(wcd,rslot) name=cnode_get_num(p,var_name) - if(name/=0) then + if(name/=0.and.rslot/=0) then wcd%wc(wcd%last+j*2)=name - wcd%wc(wcd%last+j*2-1)=wcd%rdata(slot+wcd%base) + wcd%wc(wcd%last+j*2-1)=rslot j=j+1 endif endif @@ -3680,7 +3682,7 @@ function alloc_param_var(wcd,typ,isref,iskey,name) result(k) if(iskey) flags=ior(flags,v_is_key) k=cvar_alloc(wcd,typ,flags,name) else - k=alloc_var(wcd,typ) + k=alloc_var(wcd,0) ! use zero type to avoid not allocating unused parameters endif end function alloc_param_var @@ -3696,7 +3698,7 @@ function alloc_result_var(wcd,typ) result(k) flags=v_is_result k=cvar_alloc(wcd,typ,flags) else - k=alloc_var(wcd,typ) + k=alloc_var(wcd,0) endif end function alloc_result_var @@ -3719,7 +3721,8 @@ function alloc_general_var(wcd,var,rv) result(k) ':',trim(pm_type_as_string(wcd%context,typ)) endif else - k=alloc_var(wcd,0) + typ=get_var_type(wcd,var,rv) + k=alloc_var(wcd,typ) endif end function alloc_general_var @@ -3732,7 +3735,7 @@ function alloc_var(wcd,typ) result(k) integer:: i integer::k if(typ==sp_sig_deactivated) then - k=-999 + k=0 return endif if(pm_is_compiling) then @@ -3776,7 +3779,7 @@ subroutine release_var(wcd,slot) integer,intent(in):: slot integer:: k if(pm_is_compiling) return - if(slot<0) return + if(slot<=0) return k=slot-pm_stack_locals+1 if(pm_debug_checks) then if(k<1.or.k>wcd%mvar) then From 53708c5bcb4a1b88edf284899007f944f381288e Mon Sep 17 00:00:00 2001 From: Tim Bellerby Date: Mon, 11 Aug 2025 14:05:55 +0100 Subject: [PATCH 36/36] Keyword arguments and other changes copied over to pmc compiler --- README.md | 91 +------- src/cfortran.f90 | 98 +++++---- src/cnodes.f90 | 1 + src/codegen.f90 | 14 +- src/infer.f90 | 11 +- src/main.f90 | 6 +- src/vmdefs.f90 | 41 ++-- src/wcoder.f90 | 538 +++++++++++++++++++++++++++-------------------- 8 files changed, 416 insertions(+), 384 deletions(-) diff --git a/README.md b/README.md index 3fa5714..c262f87 100644 --- a/README.md +++ b/README.md @@ -1,94 +1,7 @@ ![ PM logo ](/PM-LOGO.png) -# PM Programming Language +# PM Programming Language -- version 0.5 development ## [www.pm-lang.org](http://www.pm-lang.org) -## Overview +This branch supports ongoing development of PM version 0.5 -The PM Programming Language is designed to facilitate the creation -of numerical models on parallel systems. It combines concepts of -parallelisation and vectorisation into a unified model using a 'strand' -as a basic unit of parallelisation. A strand is a very lightweight -entity that does not require its own stack and can map to a single execution -of a loop body. Strands are used in both data and task parallelism and can communicate -with other strands, including those running on other nodes. PM uses a modified form of -the Partitioned Global Address Space approach which builds synchronisation into basic operations -and excludes race conditions. -The PM compiler currently cross-compiles to Fortran+MPI. More target language/library -combinations are planned, including Fortran-MPI-OpenMP and accelerator support (initially -via either OpenMP or OpenACC) - -The PM interpreter uses a parallel virtual machine and is designed for debugging PM code. - -The language specification (available in /doc) while incomplete in places, will give -a good view of the features of the version 0.4 of the language. - -## Status - -This is a pre-release version of the PM language. While syntax and semantics are now well -developed, there may be further changes to both in response to feedback. - -The implementation is not yet fully free of bugs or unimplemented features. If you encounter -a problem, then please check the latest code on GitHub. If this does not work, then please -raise an issue. - -## Contribution - -This is an open source project and outside contributions are entirely welcome. - -At this stage the most effective contributions are in the are of testing and -feedback on the language design and implementation. - -A refactoring of compiler/interpreter source code is underway for version 0.5. -One goal of this will be to make the code more accessible to outside contributors. -In the meantime, bug-fix contributions to the source code by the brave are certainly welcome. - - -## Installation and use - -This is an initial release of version 0.4 of the language. At the moment -the code is designed to be compiled and installed on a Linux system with -MPI. It should be possible to compile on other systems with MPI and Fortan. - -To compile PM: - -Make sure you have MPI installed and loaded and can run mpifort and mpirun - -The current setup is developed on Fedora with gfortran and openmp. You -can edit pm/Makefile and pmc/Makefile to change compilers. - -The code should be fairly portable. Portability issues may be addressed by -editing config/sysdep.f90 (read the comments) - -To compile the interpreter: - - cd pm - - make clean - - make - -You can then run the interpreter (./pm --help for options) - -mpirun the interpreter for distributed execution. - -To compile PM-to-Fortran compiler: - - cd pmc - - make clean - - make - -To compile a PM program to Fortran use ./pmc (./pmc --help for options) - -The pmc compiler does not use MPI. - -The compiled code will appear as PMOUT.F90 and will need to be compiled using mpifort. - -You can then mpirun the resulting executable. - -Both compiler and interpreter expect PM source files to have a .pmm extension. - - -## Watch out for continuing updates. diff --git a/src/cfortran.f90 b/src/cfortran.f90 index 38a313f..608af0e 100644 --- a/src/cfortran.f90 +++ b/src/cfortran.f90 @@ -281,7 +281,7 @@ subroutine g_print_out(g,iunit,index,tsets) type(gen_state):: g integer,intent(in):: iunit,index logical,intent(in),optional:: tsets - call print_comp_proc(g%context,iunit,g%name,index,g%rvar,g%vevar,g%pvar,& + call print_comp_proc(g%context,iunit,g%name,index,g%rvar,g%vevar,g%pvar,0,& g%codes,1,g%vars,g%procs,g%fn%data%ptr(g%fn%offset:),2,.true.,g%wstack,tsets,& oindex=g%vardata%oindex) end subroutine g_print_out @@ -293,8 +293,8 @@ subroutine gen_proc(g,p,no) type(gen_state):: g type(pm_ptr),intent(in)::p integer,intent(in):: no - integer:: i,n,rvar,pvar,vevar,name,start - type(pm_ptr)::q,taint,keys + integer:: i,n,rvar,pvar,keys,vevar,name,start + type(pm_ptr)::q,taint logical:: iscomm ! Get wordcodes & meta-info for this function @@ -307,9 +307,9 @@ subroutine gen_proc(g,p,no) vevar=q%data%i(q%offset+3) g%codes=>q%data%i(q%offset+4:q%offset+pm_fast_esize(q)) taint=p%data%ptr(p%offset+2) - keys=p%data%ptr(p%offset+3) + keys=p%data%ptr(p%offset+3)%offset g%taints=taint%offset - iscomm=iand(int(taint%offset),proc_is_comm)/=0 + iscomm=iand(int(taint%offset),proccall_is_comm)/=0 g%rvar=rvar g%pvar=pvar @@ -333,12 +333,8 @@ subroutine gen_proc(g,p,no) if(vevar/=-1) then call create_var(g,vevar,.false.) endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call create_var(g,keys%data%i(keys%offset+i),.false.) - enddo - endif if(pvar/=-1) call create_var(g,pvar,.false.) + if(keys/=-1) call create_var(g,keys,.false.) if(size(g%codes)>0) call create_vars_for_block(g,comp_op_start) if(rvar/=-1) call create_var(g,rvar,.false.) @@ -362,12 +358,8 @@ subroutine gen_proc(g,p,no) call use_var(g,vevar) call cross_var(g,vevar) endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call use_var(g,keys%data%i(keys%offset+i)) - enddo - endif if(pvar/=-1) call use_var(g,pvar) + if(keys/=-1) call use_var(g,keys) if(size(g%codes)>0) call gen_var_block(g,comp_op_start) if(rvar/=-1) call use_var(g,rvar) @@ -390,7 +382,7 @@ subroutine gen_proc(g,p,no) endif if(iand(int(taint%offset),proc_is_recursive)/=0) & call out_str(g,'RECURSIVE ') - if(iand(int(taint%offset),proc_is_impure)==0) & + if(iand(int(taint%offset),proc_is_impure)==0.and..not.keys>0) & call out_str(g,'PURE ') call out_str(g,'SUBROUTINE PM__P') call out_idx(g,no) @@ -408,14 +400,12 @@ subroutine gen_proc(g,p,no) if(rvar/=-1) then call out_param(g,rvar) endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call out_param(g,keys%data%i(keys%offset+i)) - enddo - endif if(pvar/=-1) then call out_param(g,pvar) endif + if(keys/=-1) then + call out_param(g,keys) + endif call out_close(g) call out_new_line(g) if(iscomm) then @@ -576,7 +566,7 @@ recursive subroutine create_var(g,avar,modify) case(v_is_sub,v_is_vsub) call create_var(g,g_v1(g,var),modify) call create_var(g,g_v2(g,var),modify) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped,v_is_keyarg) call create_var(g,g_v1(g,var),modify) case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) continue @@ -782,7 +772,7 @@ recursive subroutine record_var_access(g,avar,mode) case(v_is_sub,v_is_vsub) call record_var_access(g,g_v1(g,var),mode) call record_var_access(g,g_v2(g,var),mode) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped,v_is_keyarg) call record_var_access(g,g_v1(g,var),mode) case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) continue @@ -1941,7 +1931,7 @@ recursive subroutine use_var(g,avar,isassign) case(v_is_sub,v_is_vsub) call use_var(g,g_v1(g,var),isassign) call use_var(g,g_v2(g,var),isassign) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped,v_is_keyarg) call use_var(g,g_v1(g,var),isassign) case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) continue @@ -1961,7 +1951,7 @@ recursive subroutine use_var(g,avar,isassign) call use_var(g,g_v1(g,var)) endif flags=g%vardata(i)%flags - if(iand(g%taints,proc_is_comm)/=0.and.& + if(iand(g%taints,proccall_is_comm)/=0.and.& iand(flags,v_is_param+v_is_result)/=0) then if(iand(flags,v_is_shared)/=0) then g%vardata(i)%state=var_state_used @@ -2067,7 +2057,7 @@ recursive subroutine cross_var(g,avar) case(v_is_sub,v_is_vsub) call cross_var(g,g_v1(g,var)) call cross_var(g,g_v2(g,var)) - case(v_is_elem,v_is_unit_elem) + case(v_is_elem,v_is_unit_elem,v_is_keyarg) call cross_var(g,g_v1(g,var)) case(v_is_alias) call cross_var(g,g_v1(g,var)) @@ -2554,6 +2544,21 @@ recursive subroutine gen_op(g,loc) enddo call out_close(g) call out_new_line(g) + case(op_get_key) + call out_str(g,'IF(PRESENT(') + call out_arg(g,g%codes(a+3),0) + call out_line(g,')) THEN') + call out_arg(g,g%codes(a+2),0) + call out_str(g,'=>') + call out_arg(g,g%codes(a+3),0) + call out_new_line(g) + call out_line(g,'ELSE') + call gen_block(g,g%codes(a+1)) + call out_arg(g,g%codes(a+2),0) + call out_str(g,'=>') + call out_arg(g,g%codes(a+4),0) + call out_new_line(g) + call out_line(g,'ENDIF') case(op_comm_loop,op_comm_loop_par) call gen_loop(g,l,.true.) need_endif=.false. @@ -5524,7 +5529,7 @@ recursive subroutine outpack(tno,varname,depth) call outpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) call out_line(g,'ENDDO') call outpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) + case(pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) @@ -5556,7 +5561,7 @@ recursive subroutine outpack(tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_literal_value,pm_type_is_fix_value) continue case(pm_type_is_all,pm_type_is_par_kind,& pm_type_is_vect) @@ -5611,7 +5616,7 @@ recursive subroutine declare_poly_vars(tno) enddo endif case(pm_type_is_array,& - pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) + pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) call declare_poly_vars(pm_tv_arg(tv,i)) enddo @@ -5651,7 +5656,7 @@ recursive subroutine outunpack(tno,varname,depth) call outunpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) call out_line(g,'ENDDO') call outunpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) + case(pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outunpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) @@ -5680,7 +5685,7 @@ recursive subroutine outunpack(tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_literal_value,pm_type_is_fix_value) continue case(pm_type_is_all,pm_type_is_par_kind,& pm_type_is_vect) @@ -5754,14 +5759,14 @@ recursive subroutine precount(g,tno,counts,has_depth) has_depth=.true. endif counts(pm_long)=counts(pm_long)+1 - case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) + case(pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) call precount(g,pm_tv_arg(tv,i),counts,has_depth) enddo case(pm_type_is_poly) counts(pm_int)=counts(pm_int)+1 has_depth=.true. - case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_literal_value,pm_type_is_fix_value) continue case default call pm_panic("precount") @@ -5850,12 +5855,12 @@ recursive subroutine outcount(g,tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) + case(pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outcount(g,pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_literal_value,pm_type_is_fix_value) continue case(pm_type_is_all,pm_type_is_par_kind,& pm_type_is_vect) @@ -6022,8 +6027,6 @@ subroutine out_var_def(g,i,iscomm) call out_str(g,',INTENT(OUT)') endif endif - - if(iand(flags,v_is_key)/=0) call out_str(g,',OPTIONAL') if(isvect) then if(iand(flags,v_is_array_par_vect+v_is_array_par_dom)/=0) then @@ -6175,7 +6178,7 @@ recursive subroutine out_alloc_var(g,avar,nc) do i=1,n call out_alloc_var(g,g_ptr(g,var,i),nc) enddo - case(v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) + case(v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem,v_is_keyarg) write(*,*) 'v_',var call pm_panic('out_alloc_var') case(v_is_cove) @@ -6365,6 +6368,8 @@ recursive subroutine out_call_arg(g,avar,opts) call out_call_arg(g,g_v1(g,var),ior(opts,arg_wrapped)) case(v_is_alias) call out_call_arg(g,g_v1(g,var),opts) + case(v_is_keyarg) + call out_arg(g,g_v1(g,var),opts) case default tno=g_type(g,var) if(pm_type_kind(g%context,tno)==pm_type_is_array) then @@ -6391,7 +6396,7 @@ end subroutine out_call_arg recursive subroutine out_dref_vect_arg(g,var,tno,opts) type(gen_state):: g integer,intent(in):: var,tno,opts - if(pm_type_get_mode(g%context,tno)>=sym_mirrored) then + if(pm_type_get_mode(g%context,tno)>=sym_uniform) then call out_call_arg(g,var,opts) else call out_call_arg(g,var,ior(opts,arg_wrapped)) @@ -6463,6 +6468,9 @@ recursive subroutine out_arg(g,avar,opts) call out_elem(g,g_v1(g,var),g_v2(g,var),opts) case(v_is_unit_elem) call out_arg(g,g_v1(g,var),opts) +!!$ case(v_is_keyarg) +!!$ i=1 +!!$ call out_key_arg(g_v1(g,var),g_v2(g,var),opts,i) case(v_is_chan_vect) call out_arg(g,g_v1(g,var),ior(opts,arg_chan)) case(v_is_const) @@ -6553,7 +6561,7 @@ end subroutine out_var_at_index subroutine out_const(g,v) type(gen_state):: g type(pm_ptr),intent(in):: v - character(len=max_line):: buffer + character(len=ftn_max_line):: buffer integer:: vk,i,n buffer=' ' vk=pm_fast_vkind(v) @@ -6814,7 +6822,7 @@ recursive function add_mpi_type(g,typ) result(j) j=add_to_root_set(tno) tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_type_is_struct,pm_type_is_rec) + case(pm_type_is_rec) do i=1,pm_tv_numargs(tv) j=add_mpi_type(g,pm_tv_arg(tv,i)) enddo @@ -7542,5 +7550,13 @@ end subroutine init_par subroutine finalise_par(context) type(pm_context),pointer:: context end subroutine finalise_par + + !=============================================== + ! Placefiller - not needed for compiler + !================================================ + subroutine pm_run_prog(context,funcs) + type(pm_context),pointer:: context + type(pm_ptr),intent(in):: funcs + end subroutine pm_run_prog end module pm_backend diff --git a/src/cnodes.f90 b/src/cnodes.f90 index 5eec820..b8a3191 100644 --- a/src/cnodes.f90 +++ b/src/cnodes.f90 @@ -145,6 +145,7 @@ module pm_cnodes integer,parameter:: var_is_maybe_not_private=4096 integer,parameter:: var_is_where=8192 integer,parameter:: var_is_reference=16384 + integer,parameter:: var_is_key_ptr=32768 ! Offsets into proc & builtin nodes integer,parameter:: pr_ptype=cnode_args+0 diff --git a/src/codegen.f90 b/src/codegen.f90 index 570803e..076c760 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -3168,7 +3168,7 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call make_temp_var(coder,cblock,node) else q=coder%var(i) - if(cnode_flags_set(q,var_flags,var_is_key)) then + if(cnode_flags_set(q,var_flags,var_is_key_ptr)) then call code_val(coder,cnode_get(q,var_extra_info)) call make_sp_call_rtn(coder,cblock,node,sym_present,1,1) else @@ -5003,6 +5003,8 @@ recursive subroutine trav_proc(coder,node) call code_val(coder,node_get(node,proc_amplocs)) call code_val(coder,node_get(node,proc_name)) + keycall=pm_null_obj + sym=node_sym(node) if(sym==sym_builtin) then @@ -5234,7 +5236,7 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) newbase=coder%top do i=1,node_numargs(p)/3 call make_var(coder,cblock,p,vname,& - flags0+var_is_param+var_is_key+var_is_multi_access+var_is_shadowed) + flags0+var_is_key+var_is_multi_access+var_is_shadowed) call code_val(coder,coder%var(base+i)) call make_sys_call(coder,cblock,node,sym_export_param,1,1) enddo @@ -5260,7 +5262,7 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) do i=1,node_numargs(p),3 vname=node_num_arg(p,i) call make_var(coder,cblock,p,vname,& - flags0+var_is_key+var_is_multi_access+var_is_shadowed,& + flags0+var_is_key_ptr+var_is_multi_access+var_is_shadowed,& extra_info=coder%var(base+(i+2)/3)) enddo @@ -5274,6 +5276,9 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) ! Create blocks to compute default values do i=1,node_numargs(p),3 cblock2=make_cblock(coder,cblock,node,sym_key) + call make_var(coder,cblock,p,node_num_arg(p,i),& + flags0+var_is_key+var_is_multi_access+var_is_shadowed) + call dup_code(coder) call trav_expr(coder,cblock2,p,node_arg(p,i+2)) tno=tkeys%data%i(tkeys%offset+n+i/3) ! For stated type constraints, convert default value to @@ -5284,10 +5289,11 @@ recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) call make_sp_call_rtn(coder,cblock2,node,sym_type_val,1,1) call make_sp_call_rtn(coder,cblock2,node,sym_cast,2,1) endif + call make_sys_call(coder,cblock2,node,sym_clone,1,1) !!! should this be clone? call close_cblock(coder,cblock2) call reveal_vars(coder,base+n+(i+2)/3,base+n+(i+2)/3) enddo - + ! Create call: key keyarg... keyvar... (block defvar)... call make_sp_call(coder,cblock,node,sym_key,n*2,n*2) key_call=cnode_get(cnode_get(cblock,cblock_last_call),call_args) diff --git a/src/infer.f90 b/src/infer.f90 index cbd3a3c..20e48b8 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -558,6 +558,7 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& call code_num(coder,rtype) call code_num(coder,new_atype) + ! Back-prop pass - push use info vectors for args and keys if(added) then call bprop(coder,cnode_get(procnode,pr_cblock),& coder%stack(coder%base+1:coder%base+cnode_get_num(procnode,pr_max_index)),& @@ -568,17 +569,18 @@ function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& .true.) endif if(proc_nkeys==0) call code_null(coder) + + ! Create record -- proc resvec flags rtype new_atype arg_uses key_uses call make_code(coder,pm_null_obj,cnode_is_resolved_proc,7) call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) call drop_code(coder) call code_num(coder,int(k)) + + ! Pop frame call pop_stack_frame(coder) call cnode_incr_num(procnode,pr_recurse,-1) - call restore_proc_state - - if(debug_inference) then write(*,*) 'ENDPROCNODE>',trim(pm_name_as_string(coder%context,& cnode_get_name(procnode,pr_name))),k,coder%taints @@ -3906,6 +3908,9 @@ subroutine bprop_call(coder,cblock,callnode,access_info,rvec) arg%data%i8(arg%offset+i+nargs-1)=access_info(size(rvec)+i) enddo case(sym_key) + do i=1,nret/2 + call access(cnode_arg(args,i)) + enddo do i=2,nargs,2 if(accessed(cnode_arg(args,i/2+nret/2))) then call access(cnode_arg(args,nret+i)) diff --git a/src/main.f90 b/src/main.f90 index 1894109..72554eb 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -84,8 +84,8 @@ program pm ! Run wordcodes or use them to generate source if(pm_is_compiling) then - if(pm_debug_level>1) write(*,*) 'OPTIMISING...' - call optimise_prog(context,code_cache,poly_cache) + if(pm_debug_level>1.or..true.) write(*,*) 'OPTIMISING...' + !call optimise_prog(context,code_cache,poly_cache) if(pm_opts%out_debug_files) then open(unit=pm_comp_file_unit,file='optimiser.out') context%funcs=code_cache @@ -93,7 +93,7 @@ program pm close(pm_comp_file_unit) endif - if(pm_debug_level>1) write(*,*) 'CREATING SOURCE...' + if(pm_debug_level>1.or..true.) write(*,*) 'CREATING SOURCE...' open(unit=9,file='PMOUT.F90') call gen_prog(context,code_cache,poly_cache,typeset,9) close(9) diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 714635a..22eec51 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -848,7 +848,7 @@ module pm_vmdefs data op_flags(op_extractelm) /0/ data op_flags(op_iota) /0/ data op_flags(op_indices) /0/ - data op_flags(op_get_key) /0/ + data op_flags(op_get_key) /op_1_block/ data op_flags(op_present) /0/ data op_flags(op_export_array) /0/ data op_flags(op_miss_arg) /0/ @@ -1431,6 +1431,7 @@ module pm_vmdefs integer,parameter:: v_is_chan_vect=13 integer,parameter:: v_is_unit_elem=14 integer,parameter:: v_is_vect_wrapped=15 + integer,parameter:: v_is_keyarg=16 integer,parameter:: cvar_flag_mask=31 integer,parameter:: cvar_flag_mult=cvar_flag_mask+1 @@ -1451,7 +1452,8 @@ module pm_vmdefs integer,parameter:: v_is_array_par_vect=2048 integer,parameter:: v_is_array_par_dom=4096 integer,parameter:: v_is_farray=8192 - integer,parameter:: v_extra_flags=16384 + integer,parameter:: v_is_key_ptr=16384 + integer,parameter:: v_extra_flags=32768 ! Variable group types (compiling only) integer,parameter:: v_is_var_array=0 @@ -2262,25 +2264,27 @@ subroutine print_comp_procs(context,iunit,funcs) type(pm_ptr),intent(in):: funcs type(pm_ptr):: p,q,qq integer(pm_ln):: idx + integer:: kvar do idx=1_pm_ln,pm_dict_size(context,funcs) p=pm_dict_val(context,funcs,idx) if(pm_fast_isnull(p)) cycle q=p%data%ptr(p%offset) qq=p%data%ptr(p%offset+1) + kvar=p%data%ptr(p%offset+3)%offset call print_comp_proc(context,iunit,q%data%i(q%offset+2),int(idx),& - q%data%i(q%offset),q%data%i(q%offset+3),q%data%i(q%offset+1),& + q%data%i(q%offset),q%data%i(q%offset+3),q%data%i(q%offset+1),kvar,& q%data%i(q%offset+4:),1,qq%data%i(qq%offset:),context%funcs,p%data%ptr(p%offset:),2,.true.) enddo contains include 'fisnull.inc' end subroutine print_comp_procs - subroutine print_comp_proc(context,iunit,name,index,rvar,vevar,pvar,& + subroutine print_comp_proc(context,iunit,name,index,rvar,vevar,pvar,kvar,& op,first_index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit integer,dimension(:),intent(in):: op,vars - integer,intent(in):: name,index,rvar,vevar,pvar,first_index,depth + integer,intent(in):: name,index,rvar,vevar,pvar,kvar,first_index,depth type(pm_ptr),intent(in):: dict type(pm_ptr),dimension(*),intent(in):: values logical,intent(in):: masked @@ -2302,10 +2306,12 @@ subroutine print_comp_proc(context,iunit,name,index,rvar,vevar,pvar,& endif if(pvar>0) then call print_cvar(context,iunit,vars,max(pvar,0),values,.true.,depth,line,i) - call append_to(iunit,line,i,'{',.true.,depth) - else - call append_to(iunit,line,i,'{',.true.,depth) endif + if(kvar>0) then + call append_to(iunit,line,i,' KEYS',.false.,depth) + call print_cvar(context,iunit,vars,max(kvar,0),values,.true.,depth,line,i) + endif + call append_to(iunit,line,i,' {',.true.,depth) if(size(op)>0) then call print_comp_op_block(context,iunit,op,first_index,vars,dict,values,2,masked,wstack,vsets,oindex) endif @@ -2316,7 +2322,7 @@ end subroutine print_comp_proc subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit - integer,dimension(*),intent(in):: op,vars + integer,dimension(:),intent(in):: op,vars integer,intent(in):: index,depth type(pm_ptr),intent(in):: dict type(pm_ptr),dimension(*),intent(in):: values @@ -2363,6 +2369,8 @@ subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked,ws nblocks=0 endif + !write(iunit,*)'>>',op(index:index+comp_op_arg0+nargs-1) + if(masked.and.op(index+comp_op_arg0)>0) then line=' ' j=depth @@ -2422,7 +2430,7 @@ end subroutine print_comp_op subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit - integer,dimension(*),intent(in):: op,vars + integer,dimension(:),intent(in):: op,vars type(pm_ptr),intent(in):: dict type(pm_ptr),dimension(*),intent(in):: values integer,intent(in):: index,depth @@ -2447,7 +2455,7 @@ end subroutine print_comp_op_block subroutine print_cvar(context,iunit,var,index,values,addtype,depth,str,i) type(pm_context),pointer:: context integer,intent(in):: iunit - integer,dimension(*),intent(in):: var + integer,dimension(:),intent(in):: var integer,intent(in):: index,depth type(pm_ptr),dimension(*),intent(in):: values logical,intent(in):: addtype @@ -2472,9 +2480,11 @@ recursive subroutine printv(index,addtype) elseif(index==0) then call append('^') return + elseif(index>size(var)) then + call append('*???*') + return end if - !write(*,*) 'index=',index kind=iand(var(index),cvar_flag_mask) v1=var(index)/cvar_flag_mult @@ -2546,6 +2556,9 @@ recursive subroutine printv(index,addtype) case(v_is_vect_wrapped) call append('%') call printv(v1,.false.) + case(v_is_keyarg) + call append(trim(pm_name_as_string(context,v2))//'=') + call printv(v1,.false.) case(v_is_group) select case(v2) case(v_is_var_array) @@ -2630,7 +2643,7 @@ subroutine print_vset(context,iunit,vset,wstack,var,values,oindex,depth) type(pm_context),pointer:: context integer,intent(in):: iunit,vset,depth integer,dimension(:),intent(in):: wstack - integer,dimension(*),intent(in):: var + integer,dimension(:),intent(in):: var type(pm_ptr),dimension(*),intent(in):: values integer,dimension(*):: oindex character(len=wcode_file_cols):: line @@ -2653,7 +2666,7 @@ subroutine print_bset(context,iunit,bset,wstack,var,values,oindex,depth) type(pm_context),pointer:: context integer,intent(in):: iunit,bset,depth integer,dimension(:),intent(in):: wstack - integer,dimension(*),intent(in):: var + integer,dimension(:),intent(in):: var type(pm_ptr),dimension(*),intent(in):: values integer,dimension(*):: oindex character(len=wcode_file_cols):: line diff --git a/src/wcoder.f90 b/src/wcoder.f90 index aa0d9a0..01a8034 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -130,8 +130,7 @@ module pm_wcode integer:: loop_top ! Return and parameter values (compiling only) - integer:: retvar,pvar - type(pm_ptr):: keys + integer:: retvar,pvar,keys ! Set of active types (compiling only) type(pm_ptr):: typeset @@ -161,7 +160,7 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) wcd%context=>context wcd%reg=>pm_register(context,'wcd',wcd%temp,& wcd%code_cache,wcd%sig_cache,wcd%poly_cache,& - wcd%true_obj,wcd%false_obj,wcd%keys) + wcd%true_obj,wcd%false_obj) wcd%code_cache=pm_dict_new(context,32_pm_ln) wcd%sig_cache=sig_cache wcd%poly_cache=poly_cache @@ -176,6 +175,7 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) if(pm_is_compiling) then wcd%typeset=pm_set_new(wcd%context,32_pm_ln) endif + wcd%keys=-1 wcd%inline_args=pm_null_obj wcd%inline_keys=pm_null_obj wcd%inline_key_names=pm_null_obj @@ -219,7 +219,7 @@ subroutine wcode_prog(wcd,p) if(pm_is_compiling) then call make_proc_code_comp(wcd,1_pm_ln,sym_pm_system,& 0,pm_fast_tinyint(wcd%context,proc_is_impure),& - pm_null_obj,ve) + ve) else call make_proc_code(wcd,1_pm_ln,sym_pm_system,ve) endif @@ -239,7 +239,7 @@ subroutine wcode_procs(wcd) type(pm_ptr):: proc,pr,rv,cblock,p,p2,tv,taints,keys integer:: ve,k integer(pm_ln):: i,j,n - integer:: nret,vev + integer:: nret,vev,rtype vev=0 wcd%base=0 i=2 @@ -251,9 +251,11 @@ subroutine wcode_procs(wcd) call init_wcode_proc(wcd,proc) pr=cnode_arg(proc,1) rv=cnode_arg(proc,2) - if(pm_fast_istiny(rv)) rv=pm_dict_val(wcd%context,wcd%poly_cache,int(rv%offset,pm_ln)) + if(pm_fast_istiny(rv)) then + rv=pm_dict_val(wcd%context,wcd%poly_cache,int(rv%offset,pm_ln)) + endif taints=cnode_arg(proc,3) - !keys=cnode_arg(proc,4) + rtype=cnode_num_arg(proc,4) if(pm_is_compiling) then ve=0 else @@ -264,21 +266,14 @@ subroutine wcode_procs(wcd) cnode_args+2,proc_is_not_inlinable) wcd%npar=cnode_get_num(pr,pr_nret)+wcd%loop_extra_arg if(pm_is_compiling) then - if(rv%data%i(rv%offset)==-1) then + if(rtype==-1) then wcd%retvar=alloc_result_var(wcd,int(pm_null)) else - wcd%retvar=alloc_result_var(wcd,rv%data%i(rv%offset)) + wcd%retvar=alloc_result_var(wcd,rtype) endif + write(*,*) 'RETVAR=',wcd%retvar,pm_type_as_string(wcd%context,rtype) + call dump_cvar(wcd,6,wcd%retvar) nret=wcd%nvar -!!$ if(.not.pm_fast_isnull(keys)) then -!!$ p2=pm_fast_newnc(wcd%context,pm_int,& -!!$ int(pm_fast_esize(keys)+1)) -!!$ wcd%keys=p2 -!!$ do j=0,pm_fast_esize(keys) -!!$ p2%data%i(p2%offset+j)=& -!!$ alloc_key_var(wcd,keys%data%i(keys%offset+j)) -!!$ enddo -!!$ endif if(wcd%loop_extra_arg/=0) then if(vev>0) then wcd%shared_ve=cvar_alloc_entry(wcd,v_is_parve,0,0,int(pm_logical)) @@ -308,7 +303,7 @@ subroutine wcode_procs(wcd) if(pm_is_compiling) then call make_proc_code_comp(wcd,i,& cnode_get_num(pr,pr_name),& - nret,taints,wcd%keys,ve) + nret,taints,ve) else call make_proc_code(wcd,i,& cnode_get_num(pr,pr_name),ve) @@ -357,7 +352,6 @@ subroutine init_wcode_proc(wcd,proc) wcd%retvar=-1 wcd%pvar=-1 wcd%shared_ve=0 - wcd%keys=pm_null_obj contains include 'fesize.inc' end subroutine init_wcode_proc @@ -413,12 +407,12 @@ end subroutine make_proc_code ! - wcode vars taints keys values... ! - wcode is retvar, pvar, name, shared_ve, wcodes... !==================================================== - subroutine make_proc_code_comp(wcd,i,name,nret,taints,keys,ve) + subroutine make_proc_code_comp(wcd,i,name,nret,taints,ve) type(wcoder),intent(inout):: wcd integer(pm_ln),intent(in):: i integer,intent(in):: name,ve integer,intent(in):: nret - type(pm_ptr),intent(in):: taints,keys + type(pm_ptr),intent(in):: taints integer:: n,m,vs,j,k type(pm_ptr):: p,p2 if(debug_wcode) then @@ -431,7 +425,7 @@ subroutine make_proc_code_comp(wcd,i,name,nret,taints,keys,ve) wcd%temp=pm_fast_new(wcd%context,pm_pointer,int(n+4,pm_p)) p=wcd%temp p%data%ptr(p%offset+2)=taints - p%data%ptr(p%offset+3)=keys + p%data%ptr(p%offset+3)%offset=wcd%keys call pm_ptr_assign(wcd%context,& pm_dict_vals(wcd%context,wcd%code_cache),i-1,p) @@ -522,7 +516,7 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))) endif rslot=alloc_param_var(wcd,& - typ,isref,.false.,cnode_get_num(p,var_name)) + typ,isref,cnode_flags_set(p,var_flags,var_is_key),cnode_get_num(p,var_name)) if(debug_wcode) write(*,*) 'TO>',wcd%rdata(slot+wcd%base) wcd%rdata(slot+wcd%base)=rslot if(rslot/=0) npar=npar+1 @@ -749,6 +743,7 @@ subroutine close_vars(wcd,cblock,rv,ve,first_pc,nvars,pp) wcd%wc(wcd%last-2)=first_pc wcd%wc(wcd%last-3)=wcd%pc-1 wcd%last=wcd%last-4-nvars*2 +!!$ write(*,*) 'CLOSING',nvars,first_pc,wcd%pc-1 endif ! Release multi-use variables @@ -766,6 +761,7 @@ subroutine close_vars(wcd,cblock,rv,ve,first_pc,nvars,pp) call release_var(wcd,rslot) name=cnode_get_num(p,var_name) if(name/=0.and.rslot/=0) then +!!$ write(*,*) 'CLOSE',trim(pm_name_as_string(wcd%context,name)),'@',rslot wcd%wc(wcd%last+j*2)=name wcd%wc(wcd%last+j*2-1)=rslot j=j+1 @@ -1385,59 +1381,80 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_logical_return,merge(1,0,ok),2,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) endif + case(sym_open) + if(pm_is_compiling.and.wcd%base==0) then + wcd%pvar=cvar_alloc_slots(wcd,3+nargs) + call cvar_set_info(wcd,wcd%pvar,v_is_group,& + nargs,v_is_tuple,0) + do kk=1,nargs + call cvar_set_ptr(wcd,wcd%pvar,kk,& + var_slot(wcd,cnode_arg(args,kk))) + enddo + endif case(sym_key) n=nargs/4 if(wcd%base==0) then - do i=1,nargs/4 - if(get_arg_type(wcd,cnode_arg(args,i+n),rv)==& - get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv).or..true.) then - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_get_key,0,5,1,ve) - pc=comp_start_block(wcd) - break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,ve) - call comp_finish_block(wcd,pc) - call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) - call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,ve) - else - new_ve=alloc_var(wcd,pm_ve_type) - call wc_call(wcd,callnode,op_get_key,0,4,0,ve) - call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) - break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) - call wc_call(wcd,callnode,op_default,0,3,1,new_ve) - call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,new_ve) - call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,new_ve) - endif - else - write(*,*) 'Diffnt',& - trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i+n),rv))),& - trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv))) - ! key arg type differs from default value - so key arg must be present + if(pm_is_compiling) then + wcd%keys=cvar_alloc_slots(wcd,3+n) + call cvar_set_info(wcd,wcd%keys,v_is_group,& + n,v_is_tuple,0) + do i=1,n + call cvar_set_ptr(wcd,wcd%keys,i,var_slot(wcd,cnode_arg(args,i))) call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& cnode_arg(args,i),wcd%base,rv,ve) - endif - enddo - else - ! Inline case - outer:do i=1,n - if(.not.pm_fast_isnull(wcd%inline_keys)) then - do j=1,cnode_numargs(wcd%inline_keys) - v=cnode_arg(wcd%inline_keys,j) - if(wcd%inline_key_names%data%i(wcd%inline_key_names%offset+j-1)==& - cnode_get_num(cnode_arg(args,i),var_name)) then - call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& - cnode_arg(wcd%inline_keys,j),wcd%oldbase,rv,ve) - cycle outer - endif - enddo - endif - break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) - call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& - cnode_arg(args,i*2+n+n),wcd%base,rv,ve) - enddo outer + enddo + else + do i=1,n + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(args,i),wcd%base,rv,ve) + enddo + endif endif + +!!$ if(wcd%base==0.and..false.) then +!!$ if(pm_is_compiling) then +!!$ wcd%keys=cvar_alloc_slots(wcd,3+n) +!!$ call cvar_set_info(wcd,wcd%keys,v_is_group,& +!!$ n,v_is_tuple,0) +!!$ endif +!!$ do i=1,n +!!$ if(pm_is_compiling) then +!!$ call cvar_set_ptr(wcd,wcd%keys,i,var_slot(wcd,cnode_arg(args,i))) +!!$ endif +!!$ if(get_arg_type(wcd,cnode_arg(args,i+n),rv)==& +!!$ get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv)) then +!!$ if(pm_is_compiling) then +!!$ call wc_call(wcd,callnode,op_get_key,0,5,1,ve) +!!$ pc=comp_start_block(wcd) +!!$ call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) +!!$ call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) +!!$ call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,ve) +!!$ break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,ve) +!!$ call comp_finish_block(wcd,pc) +!!$ else +!!$ new_ve=alloc_var(wcd,pm_ve_type) +!!$ call wc_call(wcd,callnode,op_get_key,0,4,0,ve) +!!$ call wc(wcd,-new_ve) +!!$ call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) +!!$ call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) +!!$ break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) +!!$ call wc_call(wcd,callnode,op_default,0,3,1,new_ve) +!!$ call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,new_ve) +!!$ call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,new_ve) +!!$ endif +!!$ else +!!$ write(*,*) 'Diffnt',& +!!$ trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i+n),rv))),& +!!$ trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv))) +!!$ ! key arg type differs from default value - so key arg must be present +!!$ call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& +!!$ cnode_arg(args,i),wcd%base,rv,ve) +!!$ endif +!!$ enddo +!!$ else +!!$ ! Inline case +!!$ +!!$ endif case(sym_is) if(check_arg_type(wcd,args,rv,1)==wcd%true_name) then call wc_call(wcd,callnode,op_logical_return,1,2,1,ve) @@ -1445,21 +1462,13 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_logical_return,0,2,1,ve) endif call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - case(sym_open) - if(pm_is_compiling.and.wcd%base==0) then - wcd%pvar=cvar_alloc_slots(wcd,3+nargs) - call cvar_set_info(wcd,wcd%pvar,v_is_group,& - nargs,v_is_tuple,0) - do kk=1,nargs - call cvar_set_ptr(wcd,wcd%pvar,kk,& - var_slot(wcd,cnode_arg(args,kk))) - enddo - endif case(sym_private,sym_set_mode,sym_const,sym_var,sym_dotdotdot,sym_open_brace,sym_amp,& sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_pm_assign) continue ! Nothing to do case(sym_null) - call wc_call_args(wcd,callnode,args,op_nullify,0,nargs,nargs,rv,ve) + if(.not.pm_is_compiling) then + call wc_call_args(wcd,callnode,args,op_nullify,0,nargs,nargs,rv,ve) + endif case(sym_cast) i=rvv(cnode_get_num(callnode,call_index)) if(i==0) then @@ -1500,13 +1509,13 @@ recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) case(sym_result) if(wcd%base==0) then if(pm_is_compiling) then - if(debug_wcode) then - write(*,*) 'RETURN-ACTUAL[',n,']:',& - trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) - endif + i=wcd%retvar + write(*,*) 'RETVAR now',wcd%retvar do kk=1,nargs arg=cnode_arg(args,kk) + write(*,*) 'i=',i + call dump_cvar(wcd,6,i) call comp_assign_to_slot(wcd,callnode,cvar_ptr(wcd,i,kk),arg,.true.,rv,ve) enddo else @@ -1786,6 +1795,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& integer:: extra_ve,ignore_args logical:: keep_ctime_const integer,dimension(-nkeys:totargs):: conv + integer,dimension(pm_max_args):: key_args if(ve2<0) then extra_ve=0 else @@ -1868,8 +1878,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& taints=cnode_get_num(procnode,node_args+2) if(wcd%inline_all.or.(wcd%proc_can_inline& .and.inlinable(procnode,args,nargs,nret,extra_ve))) then - call wcode_inlined_call(wcd,callnode,rv,ve1,ve2,args,nargs,& - totargs,nret,taints,procnode,varg,conv) + call wcode_inlined_call(wcd,callnode,rv,ve1,ve2,args,nargs,& + totargs,nret,taints,procnode,varg,conv,nkeys) wcd%inline_all=save_inline_all return else @@ -1925,11 +1935,17 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& if(pm_is_compiling.and.extra_ve>0) then extra_ve=0 endif + + ! Inline key args + if(nkeys>0) then + call wcode_inlined_call(wcd,callnode,rv,ve1,ve2,args,nargs,& + totargs,nret,taints,procnode,varg,conv,nkeys,key_args) + endif ! Start coding the call instruction !write(*,*) 'CALLVE>',ve1 call wc_call(wcd,callnode,op,op2,& - totargs+extra_ve+1-ignore_args+merge(nkeys,nproc_keys,pm_is_compiling),nret,ve1) + totargs+extra_ve+1-ignore_args+nproc_keys,nret,ve1) if(extra_ve>0) then call wc(wcd,ve2) endif @@ -1979,33 +1995,42 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif enddo - ! Code keyword arguments - if(pm_is_compiling) then - ! ... TODO ... - else - if(pm_fast_isnull(keys)) then - do j=1,nproc_keys - call wc(wcd,& - -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) - enddo - else - outer: do j=1,nproc_keys - do i=1,nkeys - if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then - if(conv(-i)>0) then - call wc_p(wcd,conv(-i),keep_ctime_const) - call release_var(wcd,conv(-i)) - else - call wc_p_arg(wcd,cnode_arg(keys,i),.false.,rv,ve1,keep_ctime_const) - endif - cycle outer - endif - enddo - call wc(wcd,& - -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) - enddo outer - endif - endif + do i=1,nproc_keys + call wc(wcd,key_args(i)) + call release_var(wcd,key_args(i)) + enddo + +!!$ ! Code keyword arguments +!!$ if(pm_is_compiling) then +!!$ do i=1,nkeys +!!$ slot=merge(conv(-i),arg_slot(wcd,cnode_arg(keys,i)),conv(-i)>0) +!!$ tno=cvar_type(wcd,slot) +!!$ call wc(wcd,cvar_alloc_entry(wcd,v_is_keyarg,slot,key_names%data%i(key_names%offset+i-1),tno)) +!!$ enddo +!!$ else +!!$ if(pm_fast_isnull(keys)) then +!!$ do j=1,nproc_keys +!!$ call wc(wcd,& +!!$ -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) +!!$ enddo +!!$ else +!!$ outer: do j=1,nproc_keys +!!$ do i=1,nkeys +!!$ if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then +!!$ if(conv(-i)>0) then +!!$ call wc_p(wcd,conv(-i),keep_ctime_const) +!!$ call release_var(wcd,conv(-i)) +!!$ else +!!$ call wc_p_arg(wcd,cnode_arg(keys,i),.false.,rv,ve1,keep_ctime_const) +!!$ endif +!!$ cycle outer +!!$ endif +!!$ enddo +!!$ call wc(wcd,& +!!$ -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) +!!$ enddo outer +!!$ endif +!!$ endif ! When compiling some args may have been disagregated ! so neeed to correct number of arguments @@ -2113,10 +2138,8 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) enddo endif -!!$ ! Cannot currently inline procs with keyword args p=cnode_arg(proc,1) - ! Forced inline/no-inline in some contexts if(wcd%inline_none) then ok=.false. @@ -2155,48 +2178,31 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) endif end function inlinable - - ! Code keyword arguments (compling only) - ! Each keyword comiled as pair of args: present/value - subroutine comp_keys(nkeys) - integer,intent(in):: nkeys - type(pm_ptr):: key - integer:: tvar,fvar,slot - tvar=cvar_alloc_const(wcd,wcd%true_obj) - fvar=cvar_alloc_const(wcd,wcd%false_obj) - key=pm_dict_val(wcd%context,wcd%sig_cache,int(idx,pm_ln)) - key=cnode_arg(key,4) - do i=1,nkeys - if(check_arg_type(wcd,args,rv,nret+i)==pm_tiny_int) then - call wc(wcd,fvar) - call wc_p(wcd,cvar_alloc(wcd,key%data%i(key%offset+i-1),0),.false.) - else - slot=arg_slot(wcd,cnode_arg(args,i+nret)) - if(slot>0) call wc(wcd,tvar) - call wc_p_arg(wcd,cnode_arg(args,i+nret),.false.,rv,ve,.false.) - endif - enddo - end subroutine comp_keys + end subroutine wcode_proc_call !==================================================================== ! Inline procedure call + ! + ! If keyargs_out is present then only inline key argument defaults !==================================================================== - subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nret,taints,proc,varg,conv) + subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nret,& + taints,proc,varg,conv,nkeys,keyargs_out) type(wcoder),intent(inout):: wcd type(pm_ptr),intent(in):: callnode,args,proc type(pm_ptr),intent(in):: old_rv integer,intent(in):: ve1,ve2 integer,intent(in):: nargs,totargs,nret,taints logical,intent(in):: varg - integer,dimension(totargs):: conv - + integer,intent(in),dimension(-nkeys:totargs):: conv + integer,intent(out),dimension(:),optional:: keyargs_out + integer:: save_base,save_oldbase,save_xbase,save_keybase,save_lbl integer:: save_loop_extra_arg type(pm_ptr):: save_args,save_rv,save_keys,save_key_names - type(pm_ptr):: pr,p,c,cblock,rv,arg,tv - integer:: pc,par,num_named,first_pc,npar,slot,i,n,xarg,tno,lastxarg,flags + type(pm_ptr):: pr,p,c,cblock,rv,arg,tv,kcallnode,kargs + integer:: pc,par,num_named,first_pc,npar,slot,i,j,n,xarg,tno,lastxarg,flags logical:: break integer:: ve integer:: nkeys @@ -2211,25 +2217,17 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre if(debug_wcode) write(*,*) 'START SHARED INLINE',pc ve=0 endif - + if(debug_wcode) write(*,*) 'START INLINING>' - save_lbl=wcd%lbbase + call save_proc_state + wcd%lbbase=wcd%lbtop - save_oldbase=wcd%oldbase - save_base=wcd%base - save_xbase=wcd%xbase - save_args=wcd%inline_args - save_keys=wcd%inline_keys - save_key_names=wcd%inline_key_names - save_rv=wcd%outer_rv - save_keybase=wcd%keybase - save_loop_extra_arg=wcd%loop_extra_arg wcd%inline_args=args wcd%inline_keys=cnode_get(callnode,call_keys) wcd%inline_key_names=pm_name_val(wcd%context,cnode_get_num(callnode,call_key_names)) - + if(debug_wcode) then write(*,*) 'INLINE PAR TYPES>>' do i=1,nargs @@ -2241,11 +2239,11 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre write(*,*) '}' enddo endif - + wcd%outer_rv=old_rv - + first_pc=wcd%pc - + pr=cnode_arg(proc,1) if(debug_wcode) write(*,*) 'Inline>',pm_name_as_string(wcd%context,cnode_get_num(pr,pr_name)) cblock=cnode_get(pr,pr_cblock) @@ -2253,28 +2251,28 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre !nkeys=cnode_get_num(pr,pr_nkeys) npar=nret+1 wcd%keybase=nret - + save_shared_ve=wcd%shared_ve wcd%shared_ve=ve2 wcd%loop_extra_arg=merge(1,0,ve2>0) wcd%rdata(wcd%top+1:wcd%top+pm_fast_esize(rv)+1)=-1 - + ! Set parameters equal to arguments p=cnode_get(cblock,cblock_first_var) - + n=cnode_numargs(args) if(varg) n=n-1 xarg=wcd%xbase+1 lastxarg=wcd%top - + if(.not.pm_fast_isnull(p)) then - do while(cnode_flags_set(p,var_flags,var_is_param)) + do while(iand(cnode_get_num(p,var_flags),var_is_param+var_is_key)==var_is_param) slot=cnode_get_num(p,var_index) if(npar>size(conv)) then write(*,*) npar,size(conv),totargs call wcode_error(wcd,callnode,'Internal Error: failed autoconversion while inlining') endif - + if(conv(npar)>0) then ! Result of auto-conversion wcd%rdata(slot+wcd%top)=conv(npar) @@ -2296,13 +2294,13 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre if(pm_fast_isnull(p)) exit enddo endif - + wcd%oldbase=wcd%base wcd%base=wcd%top wcd%top=wcd%top+pm_fast_esize(rv)+1 wcd%xbase=wcd%top if(wcd%top>max_code_stack) call pm_panic('out of code stack') - + ! Capture excess args into args... stored at top of frame if(debug_wcode) write(*,*) 'COPY EXCESSS> ',npar,n if(npar<=n) then @@ -2328,7 +2326,7 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre endif enddo endif - + ! Copy over unused args... to top of frame if(debug_wcode) write(*,*) 'COPY UNUSED> -',xarg,lastxarg do i=xarg,lastxarg @@ -2338,22 +2336,60 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre write(*,*) 'COPY ARG TO TOP>',i,wcd%rdata(i),wcd%rdata(wcd%top) endif enddo - + ! Allocate multiple-use variables num_named=wcode_mvars(wcd,cblock,rv,ve,p) - + + ! link keyword arguments + kcallnode=cnode_get(pr,pr_keycall) + if(.not.pm_fast_isnull(kcallnode)) then + kargs=kcallnode !cnode_get(kcallnode,call_args) + n=cnode_numargs(kargs)/4 + outer:do i=1,n + if(.not.pm_fast_isnull(wcd%inline_keys)) then + do j=1,cnode_numargs(wcd%inline_keys) + if(wcd%inline_key_names%data%i(wcd%inline_key_names%offset+j-1)==& + cnode_get_num(cnode_arg(kargs,i),var_name)) then + if(conv(-j)>0) then + call arg_set_slot(wcd,cnode_arg(kargs,i+n),conv(-j)) + else + call link_to_val(wcd,kcallnode,cnode_arg(kargs,i+n),wcd%base,& + cnode_arg(wcd%inline_keys,j),wcd%oldbase,rv,ve) + endif + cycle outer + endif + enddo + endif + break=wcode_cblock(wcd,cnode_arg(kargs,i*2+n+n-1),rv,ve) + call link_to_val(wcd,kcallnode,cnode_arg(kargs,i+n),wcd%base,& + cnode_arg(kargs,i*2+n+n),wcd%base,rv,ve) + enddo outer + endif + + if(debug_wcode) then write(*,*) 'INLINE...',wcd%base,wcd%oldbase endif - - ! Process calls - c=cnode_get(cblock,cblock_first_call) - do while(.not.pm_fast_isnull(c)) - if(debug_wcode) write(*,*) 'INLINE> ve=',wcd%shared_ve - break=wcode_call(wcd,c,rv,ve,.false.) - c=cnode_get(c,call_link) - enddo - + + if(present(keyargs_out)) then + + ! Copy out keyargs + do i=1,n + keyargs_out(i)=arg_slot(wcd,cnode_arg(kargs,i+n)) + call preserve_var(wcd,keyargs_out(i)) + enddo + + else + + ! Process calls + c=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(c)) + if(debug_wcode) write(*,*) 'INLINE> ve=',wcd%shared_ve + break=wcode_call(wcd,c,rv,ve,.false.) + c=cnode_get(c,call_link) + enddo + endif + if(debug_wcode) then write(*,*) '...INLINED',wcd%base,wcd%oldbase endif @@ -2361,24 +2397,12 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre if(debug_wcode) write(*,*) 'Inlined>>',pm_name_as_string(wcd%context,cnode_get_num(pr,pr_name)) ! Close multi-use variables + ! Note returns/keyargs_out must be used immediately as they may be linked to variables + ! flagged for re-use if(.not.pm_is_compiling) then call close_vars(wcd,cblock,rv,ve,first_pc,num_named,p) endif - - wcd%top=wcd%base - wcd%xbase=save_xbase - wcd%base=save_base - wcd%oldbase=save_oldbase - wcd%outer_rv=save_rv - wcd%inline_args=save_args - wcd%inline_keys=save_keys - wcd%inline_key_names=save_key_names - wcd%keybase=save_keybase - wcd%shared_ve=save_shared_ve - wcd%lbtop=wcd%lbbase - wcd%lbbase=save_lbl - wcd%loop_extra_arg=save_loop_extra_arg - + ! Close down parameters releasing vars if(.not.pm_is_compiling) then do i=nret+1,nargs @@ -2391,14 +2415,46 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre enddo endif + call restore_proc_state + if(pm_is_compiling.and.ve1==shared_op_flag) then call comp_finish_block(wcd,pc) if(debug_wcode) write(*,*) 'FINISH SHARED',pc endif - + contains include 'fesize.inc' include 'fisnull.inc' + + subroutine save_proc_state + save_lbl=wcd%lbbase + save_oldbase=wcd%oldbase + save_base=wcd%base + save_xbase=wcd%xbase + save_args=wcd%inline_args + save_keys=wcd%inline_keys + save_key_names=wcd%inline_key_names + save_rv=wcd%outer_rv + save_keybase=wcd%keybase + save_loop_extra_arg=wcd%loop_extra_arg + end subroutine save_proc_state + + subroutine restore_proc_state + wcd%top=wcd%base + wcd%xbase=save_xbase + wcd%base=save_base + wcd%oldbase=save_oldbase + wcd%outer_rv=save_rv + wcd%inline_args=save_args + wcd%inline_keys=save_keys + wcd%inline_key_names=save_key_names + wcd%keybase=save_keybase + wcd%shared_ve=save_shared_ve + wcd%lbtop=wcd%lbbase + wcd%lbbase=save_lbl + wcd%loop_extra_arg=save_loop_extra_arg + end subroutine restore_proc_state + end subroutine wcode_inlined_call !==================================================================== @@ -2416,13 +2472,23 @@ function comp_transform_op(wcd,callnode,op,op2,args,nargs,totargs,& integer:: slot,slot2,slot3,i integer,dimension(totargs):: argslot - do i=1,totargs - if(conv(i)>0) then + do i=1,nret + if(conv(i)>0) then argslot(i)=conv(i) else argslot(i)=cvar_strip_alias(wcd,arg_slot(wcd,cnode_arg(args,i))) endif enddo + + ! Exclude the Topology parameter + + do i=nret+2,totargs + if(conv(i)>0) then + argslot(i-1)=conv(i) + else + argslot(i-1)=cvar_strip_alias(wcd,arg_slot(wcd,cnode_arg(args,i))) + endif + enddo finished=.true. select case(op) @@ -3652,20 +3718,6 @@ function add_const(wcd,val) result(n) include 'fvkind.inc' end function add_const - !==================================================================== - ! Allocate keyword parameter variable - !==================================================================== - function alloc_key_var(wcd,typ) result(k) - type(wcoder),intent(inout):: wcd - integer,intent(in):: typ - integer:: k - k=cvar_alloc_slots(wcd,5) - call cvar_set_info(wcd,k,v_is_group,2,v_is_tuple,typ) - call cvar_set_ptr(wcd,k,1,cvar_alloc(wcd,int(pm_logical),& - v_is_param)) - call cvar_set_ptr(wcd,k,2,cvar_alloc(wcd,typ,v_is_param)) - end function alloc_key_var - !==================================================================== ! Allocate parameter variable !==================================================================== @@ -3709,11 +3761,21 @@ function alloc_general_var(wcd,var,rv) result(k) type(wcoder),intent(inout):: wcd type(pm_ptr),intent(in):: var,rv integer:: k - integer:: typ,flags + integer:: typ,flags,vflags if(pm_is_compiling) then typ=get_var_type(wcd,var,rv) flags=0 - if(arg_is_par_var(var)) flags=ior(flags,v_is_par) + vflags=cnode_get_num(var,var_flags) + if(iand(vflags,var_is_par_var+var_is_key+var_is_key_ptr)/=0) then + if(iand(vflags,var_is_key)/=0) then + flags=ior(flags,v_is_key) + if(iand(vflags,var_is_param)/=0) then + flags=ior(flags,v_is_param) + endif + endif + if(iand(vflags,var_is_key_ptr)/=0) flags=ior(flags,v_is_key_ptr) + if(iand(vflags,var_is_par_var)/=0) flags=ior(flags,v_is_par) + endif k=cvar_alloc(wcd,typ,flags,cnode_get_num(var,var_name)) if(debug_wcode) then write(*,*) 'ALLOC GENERAL VAR',cnode_get_num(var,var_index),';',k,'::',cvar_kind(wcd,k),':',& @@ -3771,6 +3833,24 @@ function alloc_var(wcd,typ) result(k) if(pm_debug_level>3) write(*,*) 'Alloc var:',k end function alloc_var + !==================================================================== + ! Increase variable reference count + !==================================================================== + subroutine preserve_var(wcd,slot) + type(wcoder),intent(inout):: wcd + integer,intent(in):: slot + integer:: k + if(pm_is_compiling) return + if(slot<=0) return + k=slot-pm_stack_locals+1 + if(pm_debug_checks) then + if(k<1.or.k>wcd%mvar) call pm_panic('preserve_var') + endif + if(k<1.or.k>wcd%mvar) return + wcd%ref_count(k)=wcd%ref_count(k)-1 + end subroutine preserve_var + + !==================================================================== ! Release variable !==================================================================== @@ -3782,10 +3862,7 @@ subroutine release_var(wcd,slot) if(slot<=0) return k=slot-pm_stack_locals+1 if(pm_debug_checks) then - if(k<1.or.k>wcd%mvar) then - write(*,*) 'k=',slot,k,wcd%mvar - call pm_panic('release var') - endif + if(k<1.or.k>wcd%mvar) call pm_panic('release_var') endif if(wcd%ref_count(k)==0) then return @@ -3945,20 +4022,19 @@ function arg_is_mvar(arg) result(ok) endif end function arg_is_mvar - !==================================================================== - ! Argument is variable created in a par statement + ! Variable flags associated with an argument (constants return 0) !==================================================================== - function arg_is_par_var(arg) result(ok) + function arg_flags(arg) result(flags) type(pm_ptr),intent(in):: arg - logical:: ok - ok=.false. + integer:: flags if(cnode_get_kind(arg)==cnode_is_var) then - if(.not.cnode_flags_clear(arg,var_flags,var_is_par_var)) then - ok=.false. - endif + flags=cnode_get_num(arg,var_flags) + else + flags=0 endif - end function arg_is_par_var + end function arg_flags + !==================================================================== ! Code one word of code @@ -4064,7 +4140,8 @@ subroutine wc_p_arg(wcd,arg,isret,rv,ve,keep_ctime_const) tno<=pm_string.or.tno==pm_string_type) then call wc(wcd,cvar_const(wcd,arg)) elseif(keep_ctime_const) then - if(pm_type_kind(wcd%context,tno)==pm_type_is_fix_value) then + if(pm_type_kind(wcd%context,tno)==pm_type_is_fix_value.or.& + pm_type_kind(wcd%context,tno)==pm_type_is_literal_value) then call wc(wcd,cvar_const(wcd,arg)) endif endif @@ -4780,6 +4857,7 @@ function cvar_ptr(wcd,n,i) result(m) call pm_panic('cvar_ptr - kind') endif if(i>wcd%vinfo(n)/cvar_flag_mult) then + call dump_cvar(wcd,6,n) write(*,*) 'i=',i,'n=',wcd%vinfo(n)/cvar_flag_mult call pm_panic('cvar_ptr > n') endif @@ -5279,10 +5357,10 @@ subroutine dump_wc(context,iunit) call dump_full_cvar(context,iunit,abs(k),2,.false.,qq%data%i(qq%offset:)) else if(k>0) then - call pm_name_string(context,proc_slot_name(p,i,int(k)),str) + call pm_name_string(context,proc_slot_name(p,i-3,int(k)),str) write(iunit,*) ' Stack:',k,trim(str) else if(k>=-pm_max_stack.or.pm_is_compiling) then - call pm_name_string(context,proc_slot_name(p,i,-int(k)),str) + call pm_name_string(context,proc_slot_name(p,i-3,-int(k)),str) write(iunit,*) ' Stackref:',k,trim(str) else if(-k-pm_max_stack>=2.and.& -k-pm_max_stack<=pm_fast_esize(p)) then