Fixes to slicing

src/array.f90

@@ -4372,7 +4372,7 @@ end subroutine fmt
     type(pm_reg),pointer:: reg
     reg=>pm_register(context,'make_string',vec,len,off)
     vsize=pm_fast_esize(ve)-1
-    esize=pm_fast_esize(v)
+    esize=max(0,pm_fast_esize(v))
     len=pm_new(context,pm_long,esize+1)
     len%data%ln(len%offset:len%offset+esize)=0
     off=pm_new(context,pm_long,esize+1)

src/codegen.f90

@@ -2383,7 +2383,7 @@ subroutine code_par_scope_end(coder,iter,node,&
 
     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+proc_run_shared+proc_run_always)
+         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)

src/parlib.f90

@@ -229,7 +229,7 @@ subroutine push_node_split(context,root)
     integer,intent(in):: root
     integer:: error,newcomm
     integer:: this_comm
-    this_comm=par_frame(par_depth)%this_comm
+    this_comm=par_frame(par_depth)%shared_comm
     call mpi_comm_split(this_comm,root,par_frame(par_depth)%this_node,&
          newcomm,error)
     par_depth=par_depth+1

src/runtime.f90

@@ -400,7 +400,7 @@ SUBROUTINE PM__PUSH_NODE_SPLIT(ROOT)
    INTEGER(PM__LN),INTENT(IN):: ROOT
    INTEGER:: ERROR,NEWCOMM
    INTEGER:: THIS_COMM
-   THIS_COMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM
+   THIS_COMM=PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM
    CALL MPI_COMM_SPLIT(THIS_COMM,INT(ROOT),PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE,&
         NEWCOMM,ERROR)
    PM__NODE_DEPTH=PM__NODE_DEPTH+1

src/sysdefs.f90

@@ -2754,6 +2754,7 @@ subroutine sysdefs(parser)
     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)
@@ -2962,15 +2963,15 @@ subroutine sysdefs(parser)
     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[j] <<PM__ignore>>) };return ''false }',&
+         ' PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <<PM__ignore>>) };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==_this_node() { '//&
+         '   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] <<PM__ignore>>)'//&
@@ -2991,17 +2992,17 @@ subroutine sysdefs(parser)
          ' 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() {'//&
+         '   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,(#v)[jj] <<PM__ignore>>)'//&
+         '       _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <<PM__ignore>>)'//&
          '     }'//&
          '   } else { '//&
          '     forall j in elem {'//&
          '       var k=_arb(x._a);'//&
          '       _bcast_shared(&k,i);'//&
-         '       _set_elem(&v,k,(#v)[j] <<PM__ignore>>)'//&
+         '       _set_elem(&v,k,element(#v,active_dims(x._s,j)) <<PM__ignore>>)'//&
          '     }'//&
          '   }'//&
          ' };return ''false}',&
@@ -3032,7 +3033,7 @@ subroutine sysdefs(parser)
          ' where xxd=#xx,xd=#x;return ''true}',line)
 
     call dcl_uproc(parser,'_assign_internal_slice(&xx:array_slice(any^mshape),s) {'//&
-         'x=xx._a[s];xx=x}',line)
+         '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));'//&
@@ -3045,14 +3046,14 @@ subroutine sysdefs(parser)
          '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() {'//&
+         '  if p/=_shrd_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() {'//&
+         '  if p/=_shrd_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)}'//&
          '};'//&
@@ -3061,30 +3062,31 @@ subroutine sysdefs(parser)
          '_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,'_xp(x:single_point,y)=single_point(low(y))',line)
-    call dcl_uproc(parser,'_xp(x,y)=y',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);'//&
+         '_push_node_dist();'//&
+         'oldpart,oldtile=overlap(xs,oldd._tile);'//&
          'newpart,newtile=overlap(xxs,newd._tile);'//&
-         'foreach pp in nodes_for_grid(newd.dist,element(xxs,oldpart)) {'//&
+         '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,overlap(xxs,element(newd.dist,p)));'//&
-         '  _send_slice(p,x,overlap(otile,tile))}'//&
+         '  if p/=_shrd_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)}'//&
          '};'//&
-         'o,oo=overlap(newpart,oldpart);'//&
-         '_set_slice(&xx,element(newtile,o),x,'//&
-         '  element(oldtile,oo));'//&
-         'foreach pp in nodes_for_grid(oldd.dist,element(xs,newpart)) {'//&
+         '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,overlap(xs,element(oldd.dist,p)));'//&
-         '   _recv_slice_sync(p,&xx,overlap(newd._tile,tile))}'//&
+         '  if p/=_shrd_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()}',line)
-
+         '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)
+
     !*************************************************
     ! REFERENCES (SUBSCRIPTS AND SLICES)
     !*************************************************
@@ -3163,15 +3165,17 @@ subroutine sysdefs(parser)
     ! 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)};'//&
+         ' var v=_v1(x);if _v4(x)==_shrd_node() { v=_getref(x,null)};'//&
          ' _bcast_shared(&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)
-
+         '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)
+
     ! *************************************************************
     ! DISTRIBUTED REFERENCES
     ! *************************************************************
@@ -3651,8 +3655,8 @@ subroutine sysdefs(parser)
     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)
+         '_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)='//&
@@ -3724,7 +3728,7 @@ subroutine sysdefs(parser)
          '  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,portion_to_send);'//&
+         '   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){'//&
@@ -3737,7 +3741,7 @@ subroutine sysdefs(parser)
          '    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),i <<PM__ignore>>)};'//&
+         ' forall i in u,j in v{_set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <<PM__ignore>>)};'//&
          ' _sync_messages(x,b);'//&
          '_copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t)}',line)
 
@@ -3789,15 +3793,16 @@ subroutine sysdefs(parser)
          '}}}};'//&
          '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),i <<PM__ignore>>)};'//&
+         ' forall i in u,j in v {_set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <<PM__ignore>>)};'//&
          ' 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,portion_to_send)};'//&
-         '       if at:_bcast_slice_shared(&b,portion_to_send)}'//&
+         '    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)
@@ -4532,6 +4537,8 @@ subroutine sysdefs(parser)
     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,&
@@ -5136,7 +5143,7 @@ subroutine sysdefs(parser)
          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) 
+         '   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()));'//&
@@ -5150,7 +5157,7 @@ subroutine sysdefs(parser)
          '     };'//&
          '     _push_node_split(p) '//&
          ' } else { '//&
-         '     _push_node_dist() '//&
+         '     _push_node_dist()'//&
          ' }; '//&
          ' elem=element(dist,p); elemsz=#elem; '//&
          ' dd=new dshape {_mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz,'//&

src/vm.f90

@@ -173,12 +173,7 @@ recursive function pm_run(context,funcin,stackin,pcin,&
        trace_var_changed=.false.
     endif
 
-    if(trace_opcodes) then
-       call proc_line_module(func,&
-            max(int(pc%offset-func%data%ptr(func%offset)%offset)-4,1),line,modl)
-       write(*,*) sys_node,pc%offset,op_names(opcode),opcode2,'(',n,' args)',&
-            '@',trim(pm_name_as_string(context,modl)),'#',line,trace_var_kind
-    endif
+
 
     oparg=pc%data%i16(pc%offset+3_pm_p)
     arg(1)=stack%data%ptr(stack%offset+oparg)
@@ -208,6 +203,13 @@ recursive function pm_run(context,funcin,stackin,pcin,&
        ve=arg(1)%data%ptr(arg(1)%offset)
        start_arg=2
     endif
+
+    if(trace_opcodes) then
+       call proc_line_module(func,&
+            max(int(pc%offset-func%data%ptr(func%offset)%offset)-4,1),line,modl)
+       write(*,*) sys_node,pc%offset,op_names(opcode),opcode2,'(',n,' args)',&
+            '@',trim(pm_name_as_string(context,modl)),'#',line,trace_var_kind,.not.ve_is_empty(ve)
+    endif
     if(trace_opargs) then
        write(*,*) 've.kind=',arg(1)%data%vkind,&
             've.vec.kind=',ve%data%vkind,'esize=',esize
@@ -573,7 +575,7 @@ recursive function pm_run(context,funcin,stackin,pcin,&
        endif
     case(op_push_node_split)
        if(.not.ve_is_empty(ve)) then
-          ! op_push_node_split ve colours
+          ! op_push_node_split ve colour
           call push_node_split(context,&
                int(arg(2)%data%ln(arg(2)%offset)))
        endif
@@ -1316,10 +1318,14 @@ recursive function pm_run(context,funcin,stackin,pcin,&
           call set_arg(2,elem_ref_get_struct_elem(context,arg(3),opcode2,esize))
        else
           if(pm_fast_vkind(arg(3))/=pm_usr) then
-             write(*,*) 'Internal error on',sys_node,opcode2
-             goto 999
+             if(.not.ve_is_empty(ve)) then
+                write(*,*) 'Internal error (not struct or rec) on',sys_node,opcode2
+                call pm_dump_tree(context,6,arg(3),2)
+                goto 999
+             endif
+          else
+             call set_arg(2,arg(3)%data%ptr(arg(3)%offset+opcode2))
           endif
-          call set_arg(2,arg(3)%data%ptr(arg(3)%offset+opcode2))
        endif
     case(op_chan_array_vect)
        v=arg(3)%data%ptr(arg(3)%offset+pm_array_vect)

src/wcoder.f90

@@ -1340,9 +1340,10 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break)
        endif
     case(sym_pm_head_node)
        if(pm_is_compiling) then
-          call wc_call(wcd,callnode,op_head_node,0,2,ve)
+          new_ve=0
+          call wc_call(wcd,callnode,op_head_node,0,2,new_ve)
           pc=comp_start_block(wcd)
-          break2=wcode_cblock(wcd,cnode_arg(args,1),rv,ve)
+          break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve)
           call comp_finish_block(wcd,pc)
        else
           new_ve=alloc_var(wcd,pm_ve_type)
@@ -1793,7 +1794,7 @@ subroutine for_statement
               'Cannot have communicating operations in partition/workshare')
       endif
       if(check_arg_type(wcd,args,rv,2)==pm_null) then
-         call for_body
+         call for_body(ve)
       else
          v=cnode_arg(args,8)
          v=cnode_arg(v,1)
@@ -1810,25 +1811,25 @@ subroutine for_statement
          else
             pc=wc_jump_call(wcd,callnode,op_jmp_noshare,0,1,ve)
          endif
-         call for_body
+         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
+            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
+            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
-      integer:: j
+    subroutine for_body(ve)
+      integer:: j,ve
       integer:: save_xbase,save_top
       save_xbase=wcd%xbase
       save_top=wcd%top