Add: testsuite for backend build scheduling routines

Author: LKedward

fpm/src/fpm_model.f90

@@ -83,7 +83,7 @@ module fpm_model
     logical :: skip = .false.
         ! Flag set if build target will be skipped (not built)
 
-    integer :: schedule
+    integer :: schedule = -1
         ! Targets in the same schedule group are guaranteed to be independent
     integer(int64), allocatable :: digest_cached
         ! Previous hash

fpm/test/fpm_test/main.f90

@@ -7,6 +7,7 @@ program fpm_testing
     use test_manifest, only : collect_manifest
     use test_source_parsing, only : collect_source_parsing
     use test_module_dependencies, only : collect_module_dependencies
+    use test_backend, only: collect_backend
     use test_versioning, only : collect_versioning
     implicit none
     integer :: stat, is
@@ -21,6 +22,7 @@ program fpm_testing
         & new_testsuite("fpm_manifest", collect_manifest), &
         & new_testsuite("fpm_source_parsing", collect_source_parsing), &
         & new_testsuite("fpm_module_dependencies", collect_module_dependencies), &
+        & new_testsuite("fpm_test_backend", collect_backend), &
         & new_testsuite("fpm_versioning", collect_versioning) &
         & ]
 

fpm/test/fpm_test/test_backend.f90

@@ -0,0 +1,353 @@
+!> Define tests for the `fpm_backend` module (build scheduling)
+module test_backend
+    use testsuite, only : new_unittest, unittest_t, error_t, test_failed
+    use test_module_dependencies, only: operator(.in.)
+    use fpm_filesystem, only: exists, mkdir, get_temp_filename
+    use fpm_model, only: build_target_t, build_target_ptr, &
+                            FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE
+    use fpm_targets, only: add_target, add_dependency
+    use fpm_backend, only: sort_target, schedule_targets
+    implicit none
+    private
+
+    public :: collect_backend
+
+contains
+
+
+    !> Collect all exported unit tests
+    subroutine collect_backend(testsuite)
+
+        !> Collection of tests
+        type(unittest_t), allocatable, intent(out) :: testsuite(:)
+
+        testsuite = [ &
+            & new_unittest("target-sort", test_target_sort), &
+            & new_unittest("target-sort-skip-all", test_target_sort_skip_all), &
+            & new_unittest("target-sort-rebuild-all", test_target_sort_rebuild_all), &
+            & new_unittest("schedule-targets", test_schedule_targets), &
+            & new_unittest("schedule-targets-empty", test_schedule_empty) &
+            ]
+            
+    end subroutine collect_backend
+
+
+    !> Check scheduling of objects with dependencies
+    subroutine test_target_sort(error)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        type(build_target_ptr), allocatable :: targets(:)
+        
+        integer :: i
+
+        targets = new_test_package()
+
+        ! Perform depth-first topological sort of targets
+        do i=1,size(targets)
+
+            call sort_target(targets(i)%ptr)
+
+        end do
+
+        ! Check target states: all targets scheduled
+        do i=1,size(targets)
+
+            if (.not.targets(i)%ptr%touched) then
+                call test_failed(error,"Target touched flag not set")
+                return
+            end if
+
+            if (.not.targets(i)%ptr%sorted) then
+                call test_failed(error,"Target sort flag not set")
+                return
+            end if
+
+            if (targets(i)%ptr%skip) then
+                call test_failed(error,"Target skip flag set incorrectly")
+                return
+            end if
+
+            if (targets(i)%ptr%schedule < 0) then
+                call test_failed(error,"Target schedule not set")
+                return
+            end if
+
+        end do
+
+        ! Check all objects sheduled before library
+        do i=2,size(targets)
+
+            if (targets(i)%ptr%schedule >= targets(1)%ptr%schedule) then
+                call test_failed(error,"Object dependency scheduled after dependent library target")
+                return
+            end if
+
+        end do
+
+        ! Check target 4 schedule before targets 2 & 3
+        do i=2,3
+            if (targets(4)%ptr%schedule >= targets(i)%ptr%schedule) then
+                call test_failed(error,"Object dependency scheduled after dependent object target")
+                return
+            end if
+        end do
+
+    end subroutine test_target_sort
+
+
+
+    !> Check incremental rebuild for existing archive 
+    !>  all object sources are unmodified: all objects should be skipped
+    subroutine test_target_sort_skip_all(error)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        type(build_target_ptr), allocatable :: targets(:)
+        
+        integer :: fh, i
+
+        targets = new_test_package()
+
+        do i=2,size(targets)
+
+            ! Mimick unmodified sources
+            allocate(targets(i)%ptr%source)
+            targets(i)%ptr%source%digest = i
+            targets(i)%ptr%digest_cached = i
+
+        end do
+
+        ! Mimick archive already exists
+        open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown")
+        close(fh)
+
+        ! Perform depth-first topological sort of targets
+        do i=1,size(targets)
+
+            call sort_target(targets(i)%ptr)
+
+        end do
+
+        ! Check target states: all targets skipped
+        do i=1,size(targets)
+
+            if (.not.targets(i)%ptr%touched) then
+                call test_failed(error,"Target touched flag not set")
+                return
+            end if
+
+            if (targets(i)%ptr%sorted) then
+                call test_failed(error,"Target sort flag set incorrectly")
+                return
+            end if
+
+            if (.not.targets(i)%ptr%skip) then
+                call test_failed(error,"Target skip flag set incorrectly")
+                return
+            end if
+
+        end do
+
+    end subroutine test_target_sort_skip_all
+
+
+    !> Check incremental rebuild for existing archive
+    !>  all but lowest source modified: all objects should be rebuilt
+    subroutine test_target_sort_rebuild_all(error)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        type(build_target_ptr), allocatable :: targets(:)
+        
+        integer :: fh, i
+
+        targets = new_test_package()
+
+        do i=2,3
+
+            ! Mimick unmodified sources
+            allocate(targets(i)%ptr%source)
+            targets(i)%ptr%source%digest = i
+            targets(i)%ptr%digest_cached = i
+
+        end do
+
+        ! Mimick archive already exists
+        open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown")
+        close(fh)
+
+        ! Perform depth-first topological sort of targets
+        do i=1,size(targets)
+
+            call sort_target(targets(i)%ptr)
+
+        end do
+
+        ! Check target states: all targets scheduled
+        do i=1,size(targets)
+
+            if (.not.targets(i)%ptr%sorted) then
+                call test_failed(error,"Target sort flag not set")
+                return
+            end if
+
+            if (targets(i)%ptr%skip) then
+                call test_failed(error,"Target skip flag set incorrectly")
+                return
+            end if
+
+        end do
+
+    end subroutine test_target_sort_rebuild_all
+
+
+    !> Check construction of target queue and schedule
+    subroutine test_schedule_targets(error)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        type(build_target_ptr), allocatable :: targets(:)
+        
+        integer :: i, j
+        type(build_target_ptr), allocatable :: queue(:)
+        integer, allocatable :: schedule_ptr(:)
+
+        targets = new_test_package()
+
+        ! Perform depth-first topological sort of targets
+        do i=1,size(targets)
+
+            call sort_target(targets(i)%ptr)
+
+        end do
+
+        ! Construct build schedule queue
+        call schedule_targets(queue, schedule_ptr, targets)
+
+        ! Check all targets enqueued
+        do i=1,size(targets)
+
+            if (.not.(targets(i)%ptr.in.queue)) then
+
+                call test_failed(error,"Target not found in build queue")
+                return
+
+            end if
+
+        end do
+
+        ! Check schedule structure
+        if (schedule_ptr(1) /= 1) then
+
+            call test_failed(error,"schedule_ptr(1) does not point to start of the queue")
+            return
+
+        end if
+
+        if (schedule_ptr(size(schedule_ptr)) /= size(queue)+1) then
+
+            call test_failed(error,"schedule_ptr(end) does not point to end of the queue")
+            return
+
+        end if
+
+        do i=1,size(schedule_ptr)-1
+
+            do j=schedule_ptr(i),(schedule_ptr(i+1)-1)
+                
+                if (queue(j)%ptr%schedule /= i) then
+
+                    call test_failed(error,"Target scheduled in the wrong region")
+                    return
+
+                end if
+    
+            end do
+    
+        end do
+
+    end subroutine test_schedule_targets
+
+
+    !> Check construction of target queue and schedule
+    !>  when there's nothing to do (all targets skipped)
+    subroutine test_schedule_empty(error)
+
+        !> Error handling
+        type(error_t), allocatable, intent(out) :: error
+
+        type(build_target_ptr), allocatable :: targets(:)
+        
+        integer :: i
+        type(build_target_ptr), allocatable :: queue(:)
+        integer, allocatable :: schedule_ptr(:)
+
+        targets = new_test_package()
+
+        do i=1,size(targets)
+
+            targets(i)%ptr%skip = .true.
+
+        end do
+
+        ! Perform depth-first topological sort of targets
+        do i=1,size(targets)
+
+            call sort_target(targets(i)%ptr)
+
+        end do
+
+        ! Construct build schedule queue
+        call schedule_targets(queue, schedule_ptr, targets)
+
+        ! Check queue is empty
+        if (size(queue) > 0) then
+
+            call test_failed(error,"Expecting an empty build queue, but not empty")
+            return
+        
+        end if
+
+        ! Check schedule loop is not entered
+        do i=1,size(schedule_ptr)-1
+
+            call test_failed(error,"Attempted to run an empty schedule")
+            return
+
+        end do
+
+    end subroutine test_schedule_empty
+
+
+    !> Helper to generate target objects with dependencies
+    function new_test_package() result(targets)
+
+        type(build_target_ptr), allocatable :: targets(:)
+
+        call add_target(targets,FPM_TARGET_ARCHIVE,get_temp_filename())
+
+        call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename())
+
+        call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename())
+
+        call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename())
+        
+        ! Library depends on all objects
+        call add_dependency(targets(1)%ptr,targets(2)%ptr)
+        call add_dependency(targets(1)%ptr,targets(3)%ptr)
+        call add_dependency(targets(1)%ptr,targets(4)%ptr)
+
+        ! Inter-object dependency
+        !  targets 2 & 3 depend on target 4
+        call add_dependency(targets(2)%ptr,targets(4)%ptr)
+        call add_dependency(targets(3)%ptr,targets(4)%ptr)
+
+    end function new_test_package
+
+
+end module test_backend

fpm/test/fpm_test/test_module_dependencies.f90

@@ -12,7 +12,7 @@ module test_module_dependencies
     implicit none
     private
 
-    public :: collect_module_dependencies
+    public :: collect_module_dependencies, operator(.in.)
 
     interface operator(.in.)
         module procedure target_in