AUTOMAP

cabal.project

@@ -5,3 +5,8 @@ package futhark
   ghc-options: -j -fwrite-ide-info -hiedir=.hie
 
 allow-newer: base, template-haskell
+
+source-repository-package
+    type: git
+    location: https://github.com/jyp/glpk-hs.git
+    tag: 1f276aa19861203ea8367dc27a6ad4c8a31c9062

default.nix

@@ -37,6 +37,12 @@ let
           zlib =
             haskellPackagesNew.callPackage ./nix/zlib.nix {zlib=pkgs.zlib;};
 
+          gasp =
+            haskellPackagesNew.callPackage ./nix/gasp.nix {};
+
+          glpk-hs =
+            haskellPackagesNew.callPackage ./nix/glpk-hs.nix {};
+
           futhark =
             # callCabal2Nix does not do a great job at determining
             # which files must be included as source, which causes
@@ -75,6 +81,7 @@ let
                   "--extra-lib-dirs=${pkgs.glibc.static}/lib"
                   "--extra-lib-dirs=${pkgs.gmp6.override { withStatic = true; }}/lib"
                   "--extra-lib-dirs=${pkgs.libffi.overrideAttrs (old: { dontDisableStatic = true; })}/lib"
+                  "--extra-lib-dirs=${pkgs.glpk.overrideAttrs (old: { dontDisableStatic = true; })}/lib"
                   # The ones below are due to GHC's runtime system
                   # depending on libdw (DWARF info), which depends on
                   # a bunch of compression algorithms.

docs/language-reference.rst

@@ -1002,9 +1002,11 @@ Syntactic sugar for ``let a = a with [i] = v in a``.
 ...............................
 
 Bind ``f`` to a function with the given parameters and definition
-(``e``) and evaluate ``body``.  The function will be treated as
-aliasing any free variables in ``e``.  The function is not in scope of
-itself, and hence cannot be recursive.
+(``e``) and evaluate ``body``. The function will be treated as
+aliasing any free variables in ``e``. The function is not in scope of
+itself, and hence cannot be recursive. While the function can be made
+polymorphic by putting in explicit size parameters, it is not
+automatically generalised the way top level functions are.
 
 ``loop pat = initial for x in a do loopbody``
 .............................................

futhark.cabal

@@ -379,6 +379,11 @@ library
       Futhark.Pkg.Types
       Futhark.Profile
       Futhark.Script
+      Futhark.Solve.GLPK
+      Futhark.Solve.LP
+      Futhark.Solve.Matrix
+      Futhark.Solve.Simplex
+      Futhark.Solve.BranchAndBound
       Futhark.Test
       Futhark.Test.Spec
       Futhark.Test.Values
@@ -419,11 +424,15 @@ library
       Language.Futhark.Tuple
       Language.Futhark.TypeChecker
       Language.Futhark.TypeChecker.Consumption
+      Language.Futhark.TypeChecker.Constraints
+      Language.Futhark.TypeChecker.Error
       Language.Futhark.TypeChecker.Names
       Language.Futhark.TypeChecker.Match
       Language.Futhark.TypeChecker.Modules
       Language.Futhark.TypeChecker.Monad
+      Language.Futhark.TypeChecker.Rank
       Language.Futhark.TypeChecker.Terms
+      Language.Futhark.TypeChecker.Terms2
       Language.Futhark.TypeChecker.Terms.Loop
       Language.Futhark.TypeChecker.Terms.Monad
       Language.Futhark.TypeChecker.Terms.Pat
@@ -496,6 +505,9 @@ library
     , mwc-random
     , prettyprinter >= 1.7
     , prettyprinter-ansi-terminal >= 1.1
+     -- remove me later
+    , glpk-hs
+    , silently
 
 executable futhark
   import: common
@@ -531,6 +543,8 @@ test-suite unit
       Futhark.Optimise.ArrayLayoutTests
       Futhark.Pkg.SolveTests
       Futhark.ProfileTests
+      Futhark.Solve.BranchAndBoundTests
+      Futhark.Solve.SimplexTests
       Language.Futhark.CoreTests
       Language.Futhark.PrimitiveTests
       Language.Futhark.SemanticTests
@@ -549,3 +563,4 @@ test-suite unit
     , tasty-hunit
     , tasty-quickcheck
     , text
+    , vector >=0.12

nix/gasp.nix

@@ -0,0 +1,14 @@
+{ mkDerivation, adjunctions, base, binary, constraints, containers
+, distributive, lib, mtl, QuickCheck
+}:
+mkDerivation {
+  pname = "gasp";
+  version = "1.4.0.0";
+  sha256 = "9a73a6ea7eb844493deb76c85c50249915e5ca29a6734a0b133a0e136c232f9f";
+  libraryHaskellDepends = [
+    adjunctions base binary constraints containers distributive mtl
+    QuickCheck
+  ];
+  description = "A framework of algebraic classes";
+  license = lib.licenses.bsd3;
+}

nix/glpk-hs.nix

@@ -0,0 +1,23 @@
+{ mkDerivation, array, base, containers, deepseq, fetchgit, gasp
+, glpk, lib, mtl
+}:
+mkDerivation {
+  pname = "glpk-hs";
+  version = "0.8";
+  src = fetchgit {
+    url = "https://github.com/ludat/glpk-hs.git";
+    sha256 = "0nly5nifdb93f739vr3jzgi16fccqw5l0aabf5lglsdkdad713q1";
+    rev = "efcb8354daa1205de2b862898353da2e4beb76b2";
+    fetchSubmodules = true;
+  };
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [ array base containers deepseq gasp mtl ];
+  librarySystemDepends = [ glpk ];
+  executableHaskellDepends = [
+    array base containers deepseq gasp mtl
+  ];
+  description = "Comprehensive GLPK linear programming bindings";
+  license = lib.licenses.bsd3;
+  mainProgram = "glpk-hs-example";
+}

prelude/soacs.fut

@@ -48,7 +48,7 @@ import "zip"
 --
 -- **Span:** *O(S(f))*
 def map 'a [n] 'x (f: a -> x) (as: [n]a) : *[n]x =
-  intrinsics.map f as
+  f as
 
 -- | Apply the given function to each element of a single array.
 --

prelude/zip.fut

@@ -6,11 +6,6 @@
 
 -- The main reason this module exists is that we need it to define
 -- SOACs like `map2`.
--- We need a map to define some of the zip variants, but this file is
--- depended upon by soacs.fut.  So we just define a quick-and-dirty
--- internal one here that uses the intrinsic version.
-local def internal_map 'a [n] 'x (f: a -> x) (as: [n]a) : *[n]x =
-  intrinsics.map f as
 
 -- | Construct an array of pairs from two arrays.
 def zip [n] 'a 'b (as: [n]a) (bs: [n]b) : *[n](a, b) =
@@ -22,15 +17,15 @@ def zip2 [n] 'a 'b (as: [n]a) (bs: [n]b) : *[n](a, b) =
 
 -- | As `zip2`@term, but with one more array.
 def zip3 [n] 'a 'b 'c (as: [n]a) (bs: [n]b) (cs: [n]c) : *[n](a, b, c) =
-  internal_map (\(a, (b, c)) -> (a, b, c)) (zip as (zip2 bs cs))
+  (\(a, (b, c)) -> (a, b, c)) (zip as (zip2 bs cs))
 
 -- | As `zip3`@term, but with one more array.
 def zip4 [n] 'a 'b 'c 'd (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) : *[n](a, b, c, d) =
-  internal_map (\(a, (b, c, d)) -> (a, b, c, d)) (zip as (zip3 bs cs ds))
+  (\(a, (b, c, d)) -> (a, b, c, d)) (zip as (zip3 bs cs ds))
 
 -- | As `zip4`@term, but with one more array.
 def zip5 [n] 'a 'b 'c 'd 'e (as: [n]a) (bs: [n]b) (cs: [n]c) (ds: [n]d) (es: [n]e) : *[n](a, b, c, d, e) =
-  internal_map (\(a, (b, c, d, e)) -> (a, b, c, d, e)) (zip as (zip4 bs cs ds es))
+  (\(a, (b, c, d, e)) -> (a, b, c, d, e)) (zip as (zip4 bs cs ds es))
 
 -- | Turn an array of pairs into two arrays.
 def unzip [n] 'a 'b (xs: [n](a, b)) : ([n]a, [n]b) =
@@ -42,18 +37,18 @@ def unzip2 [n] 'a 'b (xs: [n](a, b)) : ([n]a, [n]b) =
 
 -- | As `unzip2`@term, but with one more array.
 def unzip3 [n] 'a 'b 'c (xs: [n](a, b, c)) : ([n]a, [n]b, [n]c) =
-  let (as, bcs) = unzip (internal_map (\(a, b, c) -> (a, (b, c))) xs)
+  let (as, bcs) = unzip ((\(a, b, c) -> (a, (b, c))) xs)
   let (bs, cs) = unzip bcs
   in (as, bs, cs)
 
 -- | As `unzip3`@term, but with one more array.
 def unzip4 [n] 'a 'b 'c 'd (xs: [n](a, b, c, d)) : ([n]a, [n]b, [n]c, [n]d) =
-  let (as, bs, cds) = unzip3 (internal_map (\(a, b, c, d) -> (a, b, (c, d))) xs)
+  let (as, bs, cds) = unzip3 ((\(a, b, c, d) -> (a, b, (c, d))) xs)
   let (cs, ds) = unzip cds
   in (as, bs, cs, ds)
 
 -- | As `unzip4`@term, but with one more array.
 def unzip5 [n] 'a 'b 'c 'd 'e (xs: [n](a, b, c, d, e)) : ([n]a, [n]b, [n]c, [n]d, [n]e) =
-  let (as, bs, cs, des) = unzip4 (internal_map (\(a, b, c, d, e) -> (a, b, c, (d, e))) xs)
+  let (as, bs, cs, des) = unzip4 ((\(a, b, c, d, e) -> (a, b, c, (d, e))) xs)
   let (ds, es) = unzip des
   in (as, bs, cs, ds, es)

shell.nix

@@ -2,7 +2,28 @@
 let
   sources = import ./nix/sources.nix;
   pkgs = import sources.nixpkgs {};
-  python = pkgs.python311Packages;
+  python = pkgs.python311.withPackages (ps: with ps; [
+    (
+      buildPythonPackage rec {
+        pname = "PuLP";
+        version = "2.7.0";
+        src = fetchPypi {
+          inherit pname version;
+          sha256 = "sha256-5z7msy1jnJuM9LSt7TNLoVi+X4MTVE4Fb3lqzgoQrmM=";
+        };
+        doCheck = false;
+      }
+    )
+    ps.mypy
+    black
+    cycler
+    numpy
+    pyopencl
+    matplotlib
+    jsonschema
+    sphinx
+    sphinxcontrib-bibtex
+  ]);
   haskell = pkgs.haskell.packages.ghc96;
 in
 pkgs.stdenv.mkDerivation {
@@ -22,6 +43,7 @@ pkgs.stdenv.mkDerivation {
       haskell.haskell-language-server
       haskellPackages.graphmod
       haskellPackages.apply-refact
+      python
       xdot
       hlint
       pkg-config
@@ -31,17 +53,8 @@ pkgs.stdenv.mkDerivation {
       ghcid
       niv
       ispc
-      python.python
-      python.mypy
-      python.black
-      python.cycler
-      python.numpy
-      python.pyopencl
-      python.matplotlib
-      python.jsonschema
-      python.sphinx
-      python.sphinxcontrib-bibtex
       imagemagick # needed for literate tests
+      glpk
     ]
     ++ lib.optionals (stdenv.isLinux)
       [ opencl-headers

src/Futhark/Internalise/Defunctionalise.hs

@@ -750,7 +750,7 @@ etaExpand e_t e = do
         M.fromList . zip (retDims ret) $
           map (ExpSubst . flip sizeFromName mempty . qualName) ext'
       ret' = applySubst (`M.lookup` extsubst) ret
-      e' = mkApply e (map (Nothing,) vars) $ AppRes (toStruct $ retType ret') ext'
+      e' = mkApply e (map (\v -> (Nothing, mempty, v)) vars) $ AppRes (toStruct $ retType ret') ext'
   pure (params, e', ret)
   where
     getType (RetType _ (Scalar (Arrow _ p d t1 t2))) =
@@ -856,7 +856,7 @@ unRetType (RetType ext t) = do
 
 defuncApplyFunction :: Exp -> Int -> DefM (Exp, StaticVal)
 defuncApplyFunction e@(Var qn (Info t) loc) num_args = do
-  let (argtypes, rettype) = unfoldFunType t
+  let (argtypes, rettype) = first (map snd) $ unfoldFunType t
   sv <- lookupVar (toStruct t) (qualLeaf qn)
 
   case sv of
@@ -908,9 +908,9 @@ liftedName _ _ = "defunc"
 defuncApplyArg ::
   String ->
   (Exp, StaticVal) ->
-  ((Maybe VName, Exp), [ParamType]) ->
+  (((Maybe VName, AutoMap), Exp), [ParamType]) ->
   DefM (Exp, StaticVal)
-defuncApplyArg fname_s (f', LambdaSV pat lam_e_t lam_e closure_env) ((argext, arg), _) = do
+defuncApplyArg fname_s (f', LambdaSV pat lam_e_t lam_e closure_env) (((argext, _), arg), _) = do
   (arg', arg_sv) <- defuncExp arg
   let env' = alwaysMatchPatSV pat arg_sv
       dims = mempty
@@ -961,18 +961,18 @@ defuncApplyArg fname_s (f', LambdaSV pat lam_e_t lam_e closure_env) ((argext, ar
   callret <- unRetType lifted_rettype
 
   pure
-    ( mkApply fname' [(Nothing, f'), (argext, arg')] callret,
+    ( mkApply fname' [(Nothing, mempty, f'), (argext, mempty, arg')] callret,
       sv
     )
 -- If 'f' is a dynamic function, we just leave the application in
 -- place, but we update the types since it may be partially
 -- applied or return a higher-order value.
-defuncApplyArg _ (f', DynamicFun _ sv) ((argext, arg), argtypes) = do
+defuncApplyArg _ (f', DynamicFun _ sv) (((argext, _), arg), argtypes) = do
   (arg', _) <- defuncExp arg
   let (argtypes', rettype) = dynamicFunType sv argtypes
       restype = foldFunType argtypes' (RetType [] rettype)
       callret = AppRes restype []
-      apply_e = mkApply f' [(argext, arg')] callret
+      apply_e = mkApply f' [(argext, mempty, arg')] callret
   pure (apply_e, sv)
 --
 defuncApplyArg fname_s (_, sv) ((_, arg), _) =
@@ -989,7 +989,7 @@ updateReturn (AppRes ret1 ext1) (AppExp apply (Info (AppRes ret2 ext2))) =
   AppExp apply $ Info $ AppRes (combineTypeShapes ret1 ret2) (ext1 <> ext2)
 updateReturn _ e = e
 
-defuncApply :: Exp -> NE.NonEmpty (Maybe VName, Exp) -> AppRes -> SrcLoc -> DefM (Exp, StaticVal)
+defuncApply :: Exp -> NE.NonEmpty ((Maybe VName, AutoMap), Exp) -> AppRes -> SrcLoc -> DefM (Exp, StaticVal)
 defuncApply f args appres loc = do
   (f', f_sv) <- defuncApplyFunction f (length args)
   case f_sv of
@@ -1006,8 +1006,8 @@ defuncApply f args appres loc = do
           (argtypes, _) = unfoldFunType $ typeOf f
       fmap (first $ updateReturn appres) $
         foldM (defuncApplyArg fname) (f', f_sv) $
-          NE.zip args $
-            NE.tails argtypes
+          NE.zip args . NE.tails . map snd $
+            argtypes
   where
     intrinsicOrHole e' = do
       -- If the intrinsic is fully applied, then we are done.