packages feed

futhark 0.12.3 → 0.13.1

raw patch · 33 files changed

+396/−194 lines, 33 files

Files

docs/man/futhark-test.rst view
@@ -51,7 +51,7 @@ ``data/`` subdirectory, containing values of the indicated types and shapes is, automatically constructed with ``futhark-dataset``.  Apart from sizes, integer constants (without any type suffix) are also-permitted.  These become ``ì32`` values.+permitted.  These become ``i32`` values.  If ``input`` is followed by an ``@`` and a file name (which must not contain any whitespace) instead of curly braces, values will be read
futhark.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9481b7958055b85d7ecbaed32f9b09d4af6d92255d1a11cf5161472dae048594+-- hash: 9e36798f8f4bb7d1cf26a2305298c0f022e8d80c05d3f4ab961a06976a711aeb  name:           futhark-version:        0.12.3+version:        0.13.1 synopsis:       An optimising compiler for a functional, array-oriented language. description:    Futhark is a small programming language designed to be compiled to                 efficient parallel code. It is a statically typed, data-parallel,
package.yaml view
@@ -1,5 +1,5 @@ name: futhark-version: "0.12.3"+version: "0.13.1" synopsis: An optimising compiler for a functional, array-oriented language. description: |   Futhark is a small programming language designed to be compiled to
rts/c/values.h view
@@ -195,11 +195,17 @@     return 1;   } -  for (int i = 0; i < dims-1; i++) {+  for (int i = 0; i < dims; i++) {     if (!next_token_is(buf, bufsize, "[")) {       return 1;     } +    next_token(buf, bufsize);++    if (sscanf(buf, "%"SCNi64, &shape[i]) != 1) {+      return 1;+    }+     if (!next_token_is(buf, bufsize, "]")) {       return 1;     }@@ -214,11 +220,15 @@     return 1;   } +  // Check whether the array really is empty.   for (int i = 0; i < dims; i++) {-    shape[i] = 0;+    if (shape[i] == 0) {+      return 0;+    }   } -  return 0;+  // Not an empty array!+  return 1; }  static int read_str_array(int64_t elem_size, str_reader elem_reader,@@ -655,8 +665,8 @@      if (len*slice_size == 0) {       printf("empty(");-      for (int64_t i = 1; i < rank; i++) {-        printf("[]");+      for (int64_t i = 0; i < rank; i++) {+        printf("[%"PRIi64"]", shape[i]);       }       printf("%s", elem_type->type_name);       printf(")");
rts/csharp/reader.cs view
@@ -564,13 +564,24 @@ {     ParseSpecificString("empty");     ParseSpecificChar('(');-    for (int i = 0; i < rank-1; i++) {-        ParseSpecificString("[]");+    int[] shape = new int[rank];+    for (int i = 0; i < rank; i++) {+        ParseSpecificString("[");+        shape[i] = Convert.ToInt32(ParseIntSigned());+        ParseSpecificString("]");     }     ParseSpecificString(typeName);     ParseSpecificChar(')'); -    return (new T[1], new int[rank]);+    // Check whether the array really is empty.+    for (int i = 0; i < rank; i++) {+        if (shape[i] == 0) {+            return (new T[1], shape);+        }+    }++    // Not an empty array!+    throw new Exception("empty() used with nonempty shape"); }  private (T[], int[]) ReadStrArray<T>(int rank, string typeName, Func<T> ReadStrScalar)
rts/python/values.py view
@@ -299,8 +299,13 @@ def read_str_empty_array(f, type_name, rank):     parse_specific_string(f, 'empty')     parse_specific_char(f, b'(')+    smallest = 1     for i in range(rank):-        parse_specific_string(f, '[]')+        parse_specific_string(f, '[')+        smallest = min(smallest, int(parse_int(f)))+        parse_specific_string(f, ']')+    if smallest != 0:+        raise ValueError     parse_specific_string(f, type_name)     parse_specific_char(f, b')') @@ -325,7 +330,7 @@         row_reader = elem_reader     else:         row_reader = nested_row_reader-    return read_str_array_elems(f, row_reader, type_name, rank-1)+    return read_str_array_elems(f, row_reader, type_name, rank)  def expected_array_dims(l, rank):   if rank > 1:@@ -613,7 +618,8 @@     elif type(v) == np.ndarray:         if np.product(v.shape) == 0:             tname = numpy_type_to_type_name(v.dtype)-            out.write('empty({}{})'.format(''.join(['[]' for _ in v.shape[1:]]), tname))+            out.write('empty({}{})'.format(''.join(['[{}]'.format(d)+                                                    for d in v.shape]), tname))         else:             first = True             out.write('[')
src/Futhark/Analysis/PrimExp.hs view
@@ -5,6 +5,7 @@   ( PrimExp (..)   , evalPrimExp   , primExpType+  , primExpSizeAtLeast   , coerceIntPrimExp   , true   , false@@ -14,7 +15,7 @@   , (.&&.), (.||.), (.<.), (.<=.), (.>.), (.>=.), (.==.), (.&.), (.|.), (.^.)   ) where -import           Data.Foldable+import           Control.Monad import           Data.Traversable import qualified Data.Map as M @@ -81,6 +82,23 @@  instance FreeIn v => FreeIn (PrimExp v) where   freeIn' = foldMap freeIn'++-- | True if the 'PrimExp' has at least this many nodes.  This can be+-- much more efficient than comparing with 'length' for large+-- 'PrimExp's, as this function is lazy.+primExpSizeAtLeast :: Int -> PrimExp v -> Bool+primExpSizeAtLeast k = maybe True (>=k) . descend 0+  where descend i _+          | i >= k = Nothing+        descend i LeafExp{} = Just (i+1)+        descend i ValueExp{} = Just (i+1)+        descend i (BinOpExp _ x y) = do x' <- descend (i+1) x+                                        descend x' y+        descend i (CmpOpExp _ x y) = do x' <- descend (i+1) x+                                        descend x' y+        descend i (ConvOpExp _ x) = descend (i+1) x+        descend i (UnOpExp _ x) = descend (i+1) x+        descend i (FunExp _ args _) = foldM descend (i+1) args  -- | Perform quick and dirty constant folding on the top level of a -- PrimExp.  This is necessary because we want to consider
src/Futhark/CLI/Autotune.hs view
@@ -32,7 +32,8 @@                     }  initialAutotuneOptions :: AutotuneOptions-initialAutotuneOptions = AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0+initialAutotuneOptions =+  AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0  compileOptions :: AutotuneOptions -> IO CompileOptions compileOptions opts = do@@ -53,7 +54,8 @@  regexGroups :: Regex -> String -> Maybe [String] regexGroups regex s = do-  (_, _, _, groups) <- matchM regex s :: Maybe (String, String, String, [String])+  (_, _, _, groups) <-+    matchM regex s :: Maybe (String, String, String, [String])   Just groups  comparisons :: String -> [(String,Int)]@@ -73,13 +75,14 @@  prepare :: AutotuneOptions -> FilePath -> IO [(DatasetName, RunDataset)] prepare opts prog = do-  spec <- testSpecFromFile prog+  spec <- testSpecFromFileOrDie prog   copts <- compileOptions opts    truns <-     case testAction spec of       RunCases ios _ _-        | Just runs <- iosTestRuns <$> find ((=="main") . iosEntryPoint) ios -> do+        | Just runs <-+            iosTestRuns <$> find ((=="main") . iosEntryPoint) ios -> do             res <- prepareBenchmarkProgram copts prog ios             case res of               Left (err, errstr) -> do@@ -112,7 +115,8 @@                   exitFailure                 Right _ -> do                   let t = timeout $ aft - bef-                  putStrLn $ "Calculated timeout for " ++ dataset ++ " : " ++ show t ++ "s"+                  putStrLn $ "Calculated timeout for " ++ dataset +++                    " : " ++ show t ++ "s"                   return (dataset, do_run t)    where run trun expected timeout path purpose = do@@ -127,7 +131,8 @@               ropts = runOptions path timeout opts'            when (optVerbose opts > 1) $-            putStrLn $ "Running with options: " ++ unwords (runExtraOptions ropts)+            putStrLn $ "Running with options: " +++            unwords (runExtraOptions ropts)            either (Left . T.unpack) (Right . averageRuntime) <$>             benchmarkDataset ropts prog "main"@@ -165,9 +170,11 @@  thresholdForest :: FilePath -> IO ThresholdForest thresholdForest prog = do-  thresholds <- getThresholds <$> readProcess ("." </> dropExtension prog) ["--print-sizes"] ""+  thresholds <- getThresholds <$>+    readProcess ("." </> dropExtension prog) ["--print-sizes"] ""   let root (v, _) = ((v, False), [])-  return $ unfoldForest (unfold thresholds) $ map root $ filter (null . snd) thresholds+  return $ unfoldForest (unfold thresholds) $+    map root $ filter (null . snd) thresholds   where getThresholds = mapMaybe findThreshold . lines         regex = makeRegex ("(.*)\\ \\(threshold\\ \\((.*)\\)\\)" :: String) @@ -238,16 +245,20 @@              case (t_run, f_run) of               (Left err, _) -> do-                when (optVerbose opts > 0) $ putStrLn $ "True comparison run failed:\n" ++ err+                when (optVerbose opts > 0) $+                  putStrLn $ "True comparison run failed:\n" ++ err                 return prefer_f               (_, Left err) -> do-                when (optVerbose opts > 0) $ putStrLn $ "False comparison run failed:\n" ++ err+                when (optVerbose opts > 0) $+                  putStrLn $ "False comparison run failed:\n" ++ err                 return prefer_t               (Right (_, runtime_t), Right (_, runtime_f)) ->                 if runtime_t < runtime_f-                then do when (optVerbose opts > 0) $ putStrLn "True branch is fastest."+                then do when (optVerbose opts > 0) $+                          putStrLn "True branch is fastest."                         return prefer_t-                else do when (optVerbose opts > 0) $ putStrLn "False branch is fastest."+                else do when (optVerbose opts > 0) $+                          putStrLn "False branch is fastest."                         return prefer_f    let (_lower, upper) = intersectRanges ranges
src/Futhark/CLI/Bench.hs view
@@ -51,7 +51,8 @@   -- Otherwise, CI tools and the like may believe we are hung and kill   -- us.   hSetBuffering stdout LineBuffering-  benchmarks <- filter (not . ignored . fst) <$> testSpecsFromPaths paths++  benchmarks <- filter (not . ignored . fst) <$> testSpecsFromPathsOrDie paths   (skipped_benchmarks, compiled_benchmarks) <-     partitionEithers <$> pmapIO (compileBenchmark opts) benchmarks
src/Futhark/CLI/Dataset.hs view
@@ -17,7 +17,8 @@ import System.Console.GetOpt import System.Random -import Language.Futhark.Syntax hiding (Value, PrimValue(..), IntValue(..), FloatValue(..))+import Language.Futhark.Syntax hiding+  (Value, ValueType, PrimValue(..), IntValue(..), FloatValue(..)) import Language.Futhark.Attributes (UncheckedTypeExp, namesToPrimTypes) import Language.Futhark.Parser import Language.Futhark.Pretty ()
src/Futhark/CLI/Misc.hs view
@@ -56,7 +56,7 @@   where dataget prog dataset = do           let dir = takeDirectory prog -          runs <- testSpecRuns <$> testSpecFromFile prog+          runs <- testSpecRuns <$> testSpecFromFileOrDie prog            let exact = filter ((dataset==) . runDescription) runs               infixes = filter ((dataset `isInfixOf`) . runDescription) runs
src/Futhark/CLI/Run.hs view
@@ -5,7 +5,7 @@  import Control.Monad.Free.Church import Control.Exception-import Data.Array+import Data.Bifunctor (first) import Data.List import Data.Loc import Data.Maybe@@ -54,12 +54,8 @@       Left err -> do         hPutStrLn stderr $ "Error when reading input: " ++ show err         exitFailure-      Right vs-        | Just vs' <- mapM convertValue vs ->-            return vs'-        | otherwise -> do-            hPutStrLn stderr "Error when reading input: irregular array."-            exitFailure+      Right vs ->+        return vs    (fname, ret) <-     case M.lookup (T.Term, entry) $ T.envNameMap tenv of@@ -69,24 +65,25 @@       _ -> do hPutStrLn stderr $ "Invalid entry point: " ++ pretty entry               exitFailure -  r <- runInterpreter' $ I.interpretFunction ienv (qualLeaf fname) inps-  case r of-    Left err -> do hPrint stderr err+  case I.interpretFunction ienv (qualLeaf fname) inps of+    Left err -> do hPutStrLn stderr err                    exitFailure-    Right res ->-      case (I.fromTuple res, isTupleRecord ret) of-        (Just vs, Just ts) -> zipWithM_ putValue vs ts-        _ -> putValue res ret+    Right run -> do+      run' <- runInterpreter' run+      case run' of+        Left err -> do hPrint stderr err+                       exitFailure+        Right res ->+          case (I.fromTuple res, isTupleRecord ret) of+            (Just vs, Just ts) -> zipWithM_ putValue vs ts+            _ -> putValue res ret  putValue :: I.Value -> TypeBase () () -> IO () putValue v t   | I.isEmptyArray v =-      putStrLn $ "empty(" ++ pretty (stripArray 1 t) ++ ")"+      putStrLn $ "empty(" ++ pretty t' ++ ")"   | otherwise = putStrLn $ pretty v--convertValue :: Value -> Maybe I.Value-convertValue (PrimValue p) = Just $ I.ValuePrim p-convertValue (ArrayValue arr _) = I.mkArray =<< mapM convertValue (elems arr)+  where t' = first (const 0) t `setUniqueness` Nonunique :: ValueType  data InterpreterConfig =   InterpreterConfig { interpreterEntryPoint :: Name
src/Futhark/CLI/Test.hs view
@@ -391,7 +391,8 @@   hSetBuffering stdout LineBuffering    let mode = configTestMode config-  all_tests <- map (makeTestCase config mode) <$> testSpecsFromPaths paths+  all_tests <- map (makeTestCase config mode) <$>+               testSpecsFromPathsOrDie paths   testmvar <- newEmptyMVar   reportmvar <- newEmptyMVar   concurrency <- getNumCapabilities
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -1754,13 +1754,13 @@   let onPart (ErrorString s) = return ("%s", [C.cexp|$string:s|])       onPart (ErrorInt32 x) = ("%d",) <$> compileExp x   (formatstrs, formatargs) <- unzip <$> mapM onPart parts-  let formatstr = "Error at %s:\n" <> concat formatstrs <> "\n"+  let formatstr = "Error at\n%s\n" <> concat formatstrs <> "\n"   stm [C.cstm|if (!$exp:e') {                    ctx->error = msgprintf($string:formatstr, $string:stacktrace, $args:formatargs);                    $items:free_all_mem                    return 1;                  }|]-  where stacktrace = intercalate " -> " (reverse $ map locStr $ loc:locs)+  where stacktrace = prettyStacktrace $ reverse $ map locStr $ loc:locs  compileCode (Allocate name (Count e) space) = do   size <- compileExp e
src/Futhark/CodeGen/Backends/GenericCSharp.hs view
@@ -74,7 +74,6 @@ import Control.Monad.RWS import Control.Arrow((&&&)) import Data.Maybe-import Data.List import qualified Data.Map.Strict as M  import Futhark.Representation.Primitive hiding (Bool)@@ -799,17 +798,18 @@ printStm (Imp.ArrayValue mem space bt ept (outer:shape)) ind e = do   ptr <- newVName "shapePtr"   first <- newVName "printFirst"-  let size = callMethod (CreateArray (Primitive $ CSInt Int32T) $ Right $ map compileDim $ outer:shape)+  let dims = map compileDim $ outer:shape+      size = callMethod (CreateArray (Primitive $ CSInt Int32T) $ Right dims)                  "Aggregate" [ Integer 1                              , Lambda (Tuple [Var "acc", Var "val"])                                       [Exp $ BinOp "*" (Var "acc") (Var "val")]                              ]-      emptystr = "empty(" ++ ppArrayType bt (length shape) ++ ")"+      emptystr = "empty(" ++ ppArrayType bt [length dims-1, length dims-2..0] ++ ")"    printelem <- printStm (Imp.ArrayValue mem space bt ept shape) ind e   return $     If (BinOp "==" size (Integer 0))-      [puts emptystr]+      [Exp $ simpleCall "Console.Write" [formatString emptystr dims]]     [ Assign (Var $ pretty first) $ Var "true"     , puts "["     , For (pretty ptr) (compileDim outer)@@ -820,9 +820,8 @@     , puts "]"     ] -    where ppArrayType :: PrimType -> Int -> String-          ppArrayType t 0 = prettyPrimType ept t-          ppArrayType t n = "[]" ++ ppArrayType t (n-1)+    where ppArrayType t [] = prettyPrimType ept t+          ppArrayType t (i:is) = "[{" ++ show i ++ "}]" ++ ppArrayType t is            prettyPrimType Imp.TypeUnsigned (IntType Int8) = "u8"           prettyPrimType Imp.TypeUnsigned (IntType Int16) = "u16"@@ -1277,7 +1276,7 @@       onPart (i, Imp.ErrorInt32 x) = (printFormatArg i,) <$> compileExp x   (formatstrs, formatargs) <- unzip <$> mapM onPart (zip ([1..] :: [Integer]) parts)   stm $ Assert e' $ String ("Error at {0}:\n" <> concat formatstrs) : (String stacktrace : formatargs)-  where stacktrace = intercalate " -> " (reverse $ map locStr $ loc:locs)+  where stacktrace = prettyStacktrace $ reverse $ map locStr $ loc:locs         printFormatArg = printf "{%d}"  compileCode (Imp.Call dests fname args) = do
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -51,7 +51,6 @@ import Control.Monad.Writer import Control.Monad.RWS import Data.Maybe-import Data.List import qualified Data.Map.Strict as M  import Futhark.Representation.Primitive hiding (Bool)@@ -911,9 +910,9 @@       onPart (Imp.ErrorInt32 x) = ("%d",) <$> compileExp x   (formatstrs, formatargs) <- unzip <$> mapM onPart parts   stm $ Assert e' (BinOp "%"-                   (String $ "Error at " ++ stacktrace ++ ": " ++ concat formatstrs)+                   (String $ "Error at\n" ++ stacktrace ++ "\n: " ++ concat formatstrs)                    (Tuple formatargs))-  where stacktrace = intercalate " -> " (reverse $ map locStr $ loc:locs)+  where stacktrace = prettyStacktrace $ reverse $ map locStr $ loc:locs  compileCode (Imp.Call dests fname args) = do   args' <- mapM compileArg args
src/Futhark/Internalise.hs view
@@ -303,7 +303,7 @@       forM flat_arrs $ \flat_arr -> do         flat_arr_t <- lookupType flat_arr         let new_shape' = reshapeOuter (map (DimNew . constant) new_shape)-                         1 $ arrayShape flat_arr_t+                         1 $ I.arrayShape flat_arr_t         letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr    | otherwise = do@@ -1011,7 +1011,7 @@    -- Generate an assertion and reshapes to ensure that buckets' and   -- img' are the same size.-  b_shape <- arrayShape <$> lookupType buckets'+  b_shape <- I.arrayShape <$> lookupType buckets'   let b_w = shapeSize 0 b_shape   cmp <- letSubExp "bucket_cmp" $ I.BasicOp $ I.CmpOp (I.CmpEq I.int32) b_w w_img   c <- assertingOne $@@ -1412,7 +1412,7 @@       certifying dim_ok $ forM arrs $ \arr' -> do         arr_t <- lookupType arr'         letSubExp desc $ I.BasicOp $-          I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ arrayShape arr_t) arr'+          I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ I.arrayShape arr_t) arr'      handle [arr] "flatten" = Just $ \desc -> do       arrs <- internaliseExpToVars "flatten_arr" arr@@ -1422,7 +1422,7 @@             m = arraySize 1 arr_t         k <- letSubExp "flat_dim" $ I.BasicOp $ I.BinOp (Mul Int32) n m         letSubExp desc $ I.BasicOp $-          I.Reshape (reshapeOuter [DimNew k] 2 $ arrayShape arr_t) arr'+          I.Reshape (reshapeOuter [DimNew k] 2 $ I.arrayShape arr_t) arr'      handle [TupLit [x, y] _] "concat" = Just $ \desc -> do       xs <- internaliseExpToVars "concat_x" x
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -743,15 +743,16 @@           -- worth inlining over keeping it in an array and reading it           -- from memory.           worthInlining e-            | length e > 10 = False -- totally ad-hoc.-          worthInlining (BinOpExp Pow{} _ _) = False-          worthInlining (BinOpExp FPow{} _ _) = False-          worthInlining (BinOpExp _ x y) = worthInlining x && worthInlining y-          worthInlining (CmpOpExp _ x y) = worthInlining x && worthInlining y-          worthInlining (ConvOpExp _ x) = worthInlining x-          worthInlining (UnOpExp _ x) = worthInlining x-          worthInlining FunExp{} = False-          worthInlining _ = True+            | primExpSizeAtLeast 20 e = False -- totally ad-hoc.+            | otherwise = worthInlining' e+          worthInlining' (BinOpExp Pow{} _ _) = False+          worthInlining' (BinOpExp FPow{} _ _) = False+          worthInlining' (BinOpExp _ x y) = worthInlining' x && worthInlining' y+          worthInlining' (CmpOpExp _ x y) = worthInlining' x && worthInlining' y+          worthInlining' (ConvOpExp _ x) = worthInlining' x+          worthInlining' (UnOpExp _ x) = worthInlining' x+          worthInlining' FunExp{} = False+          worthInlining' _ = True  sliceSlice :: MonadBinder m =>               [DimIndex SubExp] -> [DimIndex SubExp] -> m [DimIndex SubExp]
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -632,9 +632,18 @@   let rts = concatMap (take 1) $ chunks as_ns $             drop (sum as_ns) $ lambdaReturnType lam       (is,vs) = splitAt (sum as_ns) $ bodyResult $ lambdaBody lam-      k_body = KernelBody () (bodyStms $ lambdaBody lam) $++  -- Maybe add certificates to the indices.+  (is', k_body_stms) <- runBinder $ do+    addStms $ bodyStms $ lambdaBody lam+    forM is $ \i ->+      if cs == mempty+      then return i+      else certifying cs $ letSubExp "scatter_i" $ BasicOp $ SubExp i++  let k_body = KernelBody () k_body_stms $                map (inPlaceReturn ispace) $-               zip3 as_ws as_inps $ chunks as_ns $ zip is vs+               zip3 as_ws as_inps $ chunks as_ns $ zip is' vs    (k, k_bnds) <- mapKernel mk_lvl ispace kernel_inps rts k_body @@ -644,7 +653,7 @@     let pat = Pattern [] $ rearrangeShape perm $               patternValueElements $ loopNestingPattern $ fst nest -    certifying cs $ letBind_ pat $ Op $ SegOp k+    letBind_ pat $ Op $ SegOp k   where findInput kernel_inps a =           maybe bad return $ find ((==a) . kernelInputName) kernel_inps         bad = error "Ill-typed nested scatter encountered."
src/Futhark/Pass/ResolveAssertions.hs view
@@ -40,7 +40,7 @@   case res of     -- If the sufficient condition is 'True', then it statically succeeds.     Just se-      | SE.scalExpType se == Bool,+      | interesting e,         isNothing $ valOrVar se,         SE.scalExpSize se < size_bound,         Just se' <- valOrVar $ AS.simplify se ranges ->@@ -52,3 +52,12 @@         valOrVar (SE.Val v)  = Just $ Constant v         valOrVar (SE.Id v _) = Just $ Var v         valOrVar _           = Nothing++        interesting CmpOp{} = True+        interesting (BinOp LogAnd _ _) = True+        interesting (BinOp LogOr _ _) = True+        interesting (BinOp _ x y) = isConst x || isConst y+        interesting _ = False++        isConst Constant{} = True+        isConst Var{} = False
src/Futhark/Test.hs view
@@ -6,7 +6,9 @@ -- block specifies input- and output-sets. module Futhark.Test        ( testSpecFromFile+       , testSpecFromFileOrDie        , testSpecsFromPaths+       , testSpecsFromPathsOrDie        , valuesFromByteString        , getValues        , getValuesBS@@ -386,17 +388,24 @@ commentPrefix :: T.Text commentPrefix = T.pack "--" +couldNotRead :: IOError -> IO (Either String a)+couldNotRead = return . Left . show+ -- | Read the test specification from the given Futhark program.--- Note: will call 'error' on parse errors.-testSpecFromFile :: FilePath -> IO ProgramTest+testSpecFromFile :: FilePath -> IO (Either String ProgramTest) testSpecFromFile path = do-  blocks <- testBlocks <$> T.readFile path-  let (first_spec_line, first_spec, rest_specs) =-        case blocks of []       -> (0, mempty, [])-                       (n,s):ss -> (n, s, ss)-  case readTestSpec (1+first_spec_line) path first_spec of-    Left err -> error $ errorBundlePretty err-    Right v  -> foldM moreCases v rest_specs+  blocks_or_err <-+    (Right . testBlocks <$> T.readFile path)+    `catch` couldNotRead+  case blocks_or_err of+    Left err -> return $ Left err+    Right blocks -> do+      let (first_spec_line, first_spec, rest_specs) =+            case blocks of []       -> (0, mempty, [])+                           (n,s):ss -> (n, s, ss)+      case readTestSpec (1+first_spec_line) path first_spec of+        Left err -> return $ Left $ errorBundlePretty err+        Right v  -> Right <$> foldM moreCases v rest_specs    where moreCases test (lineno, cases) =           case readInputOutputs lineno path cases of@@ -407,6 +416,15 @@                   return test { testAction = RunCases (old_cases ++ cases') structures warnings }                 _ -> fail "Secondary test block provided, but primary test block specifies compilation error." +-- | Like 'testSpecFromFile', but kills the process on error.+testSpecFromFileOrDie :: FilePath -> IO ProgramTest+testSpecFromFileOrDie prog = do+  spec_or_err <- testSpecFromFile prog+  case spec_or_err of+    Left err -> do putStrLn err+                   exitFailure+    Right spec -> return spec+ testBlocks :: T.Text -> [(Int, T.Text)] testBlocks = mapMaybe isTestBlock . commentBlocks   where isTestBlock (n,block)@@ -429,20 +447,32 @@  -- | Read test specifications from the given path, which can be a file -- or directory containing @.fut@ files and further directories.--- Calls 'error' on parse errors, or if the given path name does not--- name a file that exists.-testSpecsFromPath :: FilePath -> IO [(FilePath, ProgramTest)]+testSpecsFromPath :: FilePath -> IO (Either String [(FilePath, ProgramTest)]) testSpecsFromPath path = do-  programs <- testPrograms path-  zip programs <$> mapM testSpecFromFile programs+  programs_or_err <- (Right <$> testPrograms path) `catch` couldNotRead+  case programs_or_err of+    Left err -> return $ Left err+    Right programs -> do+      specs_or_errs <- mapM testSpecFromFile programs+      return $ zip programs <$> sequence specs_or_errs  -- | Read test specifications from the given paths, which can be a -- files or directories containing @.fut@ files and further--- directories.  Calls 'error' on parse errors, or if any of the--- immediately passed path names do not name a file that exists.-testSpecsFromPaths :: [FilePath] -> IO [(FilePath, ProgramTest)]-testSpecsFromPaths = fmap concat . mapM testSpecsFromPath+-- directories.+testSpecsFromPaths :: [FilePath]+                   -> IO (Either String [(FilePath, ProgramTest)])+testSpecsFromPaths = fmap (fmap concat . sequence) . mapM testSpecsFromPath +-- | Like 'testSpecsFromPaths', but kills the process on errors.+testSpecsFromPathsOrDie :: [FilePath]+                        -> IO [(FilePath, ProgramTest)]+testSpecsFromPathsOrDie dirs = do+  specs_or_err <- testSpecsFromPaths dirs+  case specs_or_err of+    Left err -> do putStrLn err+                   exitFailure+    Right specs -> return specs+ testPrograms :: FilePath -> IO [FilePath] testPrograms dir = filter isFut <$> directoryContents dir   where isFut = (==".fut") . takeExtension@@ -456,13 +486,13 @@ -- | Get the actual core Futhark values corresponding to a 'Values' -- specification.  The 'FilePath' is the directory which file paths -- are read relative to.-getValues :: MonadIO m => FilePath -> Values -> m [Value]+getValues :: (MonadFail m, MonadIO m) => FilePath -> Values -> m [Value] getValues _ (Values vs) =   return vs getValues dir v = do   s <- getValuesBS dir v   case valuesFromByteString file s of-    Left e   -> error $ show e+    Left e   -> fail e     Right vs -> return vs   where file = case v of Values{} -> "<values>"                          InFile f -> f@@ -557,7 +587,7 @@         clean c = c  -- | Get the values corresponding to an expected result, if any.-getExpectedResult :: MonadIO m =>+getExpectedResult :: (MonadFail m, MonadIO m) =>                      FilePath -> T.Text -> TestRun                   -> m (ExpectedResult [Value]) getExpectedResult prog entry tr =
src/Futhark/Test/Values.hs view
@@ -140,7 +140,7 @@   ppr v | product (valueShape v) == 0 =             text "empty" <>             parens (dims <> ppr (valueElemType v))-    where dims = mconcat $ replicate (length (valueShape v)-1) $ text "[]"+    where dims = mconcat $ map (brackets . ppr) $ valueShape v   ppr (Int8Value shape vs) = pprArray (UVec.toList shape) vs   ppr (Int16Value shape vs) = pprArray (UVec.toList shape) vs   ppr (Int32Value shape vs) = pprArray (UVec.toList shape) vs@@ -388,31 +388,34 @@   return (pt, dropSpaces b)   where (a,b) = BS.span constituent t -readEmptyArrayOfRank :: Int -> BS.ByteString -> Maybe (Value, BS.ByteString)-readEmptyArrayOfRank r t+readEmptyArrayOfShape :: [Int] -> BS.ByteString -> Maybe (Value, BS.ByteString)+readEmptyArrayOfShape shape t   | Just t' <- symbol '[' t,-    Just t'' <- symbol ']' t' = readEmptyArrayOfRank (r+1) t''+    Just (d, t'') <- readIntegral (const Nothing) t',+    Just t''' <- symbol ']' t'' = readEmptyArrayOfShape (shape++[d]) t'''+   | otherwise = do       (pt, t') <- readPrimType t+      guard $ elem 0 shape       v <- case pt of-             "i8" -> Just $ Int8Value (UVec.replicate r 0) UVec.empty-             "i16" -> Just $ Int16Value (UVec.replicate r 0) UVec.empty-             "i32" -> Just $ Int32Value (UVec.replicate r 0) UVec.empty-             "i64" -> Just $ Int64Value (UVec.replicate r 0) UVec.empty-             "u8" -> Just $ Word8Value (UVec.replicate r 0) UVec.empty-             "u16" -> Just $ Word16Value (UVec.replicate r 0) UVec.empty-             "u32" -> Just $ Word32Value (UVec.replicate r 0) UVec.empty-             "u64" -> Just $ Word64Value (UVec.replicate r 0) UVec.empty-             "f32" -> Just $ Float32Value (UVec.replicate r 0) UVec.empty-             "f64" -> Just $ Float64Value (UVec.replicate r 0) UVec.empty-             "bool" -> Just $ BoolValue (UVec.replicate r 0) UVec.empty+             "i8" -> Just $ Int8Value (UVec.fromList shape) UVec.empty+             "i16" -> Just $ Int16Value (UVec.fromList shape) UVec.empty+             "i32" -> Just $ Int32Value (UVec.fromList shape) UVec.empty+             "i64" -> Just $ Int64Value (UVec.fromList shape) UVec.empty+             "u8" -> Just $ Word8Value (UVec.fromList shape) UVec.empty+             "u16" -> Just $ Word16Value (UVec.fromList shape) UVec.empty+             "u32" -> Just $ Word32Value (UVec.fromList shape) UVec.empty+             "u64" -> Just $ Word64Value (UVec.fromList shape) UVec.empty+             "f32" -> Just $ Float32Value (UVec.fromList shape) UVec.empty+             "f64" -> Just $ Float64Value (UVec.fromList shape) UVec.empty+             "bool" -> Just $ BoolValue (UVec.fromList shape) UVec.empty              _  -> Nothing       return (v, t')  readEmptyArray :: BS.ByteString -> Maybe (Value, BS.ByteString) readEmptyArray t = do   t' <- symbol '(' =<< lexeme "empty" t-  (v, t'') <- readEmptyArrayOfRank 1 t'+  (v, t'') <- readEmptyArrayOfShape [] t'   t''' <- symbol ')' t''   return (v, t''') @@ -494,7 +497,8 @@  compareValue :: Int -> Value -> Value -> [Mismatch] compareValue i got_v expected_v-  | valueShape got_v == valueShape expected_v =+  | product (valueShape got_v) == 0 && product (valueShape expected_v) == 0+    || valueShape got_v == valueShape expected_v =     case (got_v, expected_v) of       (Int8Value _ got_vs, Int8Value _ expected_vs) ->         compareNum 1 got_vs expected_vs
src/Language/Futhark/Attributes.hs view
@@ -21,6 +21,7 @@   , progModuleTypes   , identifierReference   , identifierReferences+  , prettyStacktrace    -- * Queries on expressions   , typeOf@@ -345,7 +346,7 @@ primValueType (FloatValue v)    = FloatType $ floatValueType v primValueType BoolValue{}       = Bool -valueType :: Value -> TypeBase () ()+valueType :: Value -> ValueType valueType (PrimValue bv) = Scalar $ Prim $ primValueType bv valueType (ArrayValue _ t) = t @@ -405,7 +406,19 @@ typeOf (RecordUpdate _ _ _ (Info t) _) = t typeOf (Unsafe e _) = typeOf e typeOf (Assert _ e _ _) = typeOf e-typeOf (DoLoop pat _ _ _ _) = patternType pat+typeOf (DoLoop pat _ form _ _) =+  -- We set all of the uniqueness to be unique.  This is intentional,+  -- and matches what happens for function calls.  Those arrays that+  -- really *cannot* be consumed will alias something unconsumable,+  -- and will be caught that way.+  second (`S.difference` S.map AliasBound bound_here) $+  patternType pat `setUniqueness` Unique+  where bound_here = S.map identName (patternIdents pat) <> form_bound+        form_bound =+          case form of+            For v _ -> S.singleton $ identName v+            ForIn forpat _ -> S.map identName (patternIdents forpat)+            While{} -> mempty typeOf (Lambda params _ _ (Info (als, t)) _) =   unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als   where bound_here = S.map identName (mconcat $ map patternIdents params)
src/Language/Futhark/Core.hs view
@@ -10,6 +10,7 @@    -- * Location utilities   , locStr+  , prettyStacktrace    -- * Name handling   , Name@@ -22,6 +23,8 @@   , baseName   , baseString   , pretty+  , quote+   -- * Special identifiers   , defaultEntryPoint @@ -119,6 +122,14 @@       first_part ++ "-" ++ show line2 ++ ":" ++ show col2   where first_part = file ++ ":" ++ show line1 ++ ":" ++ show col1 +-- | Given a list of strings representing entries in the stack trace,+-- produce a final newline-terminated string for showing to the user.+-- This string should also be preceded by a newline.+prettyStacktrace :: [String] -> String+prettyStacktrace = unlines . reverse . stacktrace' . reverse+  where stacktrace' (x:xs) = (" `-> " ++ x) : map (" |-> "++) xs+        stacktrace' [] = []+ -- | A name tagged with some integer.  Only the integer is used in -- comparisons, no matter the type of @vn@. data VName = VName !Name !Int@@ -141,3 +152,9 @@  instance Ord VName where   VName _ x `compare` VName _ y = x `compare` y++-- | Enclose a string in the prefered quotes used in error messages.+-- These are picked to not collide with characters permitted in+-- identifiers.+quote :: String -> String+quote s = "`" ++ s ++ "`"
src/Language/Futhark/Interpreter.hs view
@@ -12,7 +12,6 @@   , ExtOp(..)   , typeEnv   , Value (ValuePrim, ValueArray, ValueRecord)-  , mkArray   , fromTuple   , isEmptyArray   ) where@@ -32,6 +31,7 @@ import Data.Loc  import Language.Futhark hiding (Value)+import qualified Language.Futhark as F import Futhark.Representation.Primitive (intValue, floatValue) import qualified Futhark.Representation.Primitive as P import qualified Language.Futhark.Semantic as T@@ -238,7 +238,7 @@ bad :: SrcLoc -> Env -> String -> EvalM a bad loc env s = stacking loc env $ do   ss <- map locStr <$> stacktrace-  liftF $ ExtOpError $ InterpreterError $ "Error at " ++ intercalate " -> " ss ++ ": " ++ s+  liftF $ ExtOpError $ InterpreterError $ "Error at\n" ++ prettyStacktrace ss ++ s  trace :: Value -> EvalM () trace v = do@@ -343,8 +343,8 @@ matchValueToType env t@(Scalar (TypeVar _ _ tn [])) val   | Just shape <- M.lookup (typeLeaf tn) $ envShapes env,     shape /= valueShape val =-      Left $ "Value passed for type parameter `" <> prettyName (typeLeaf tn) <>-      "` does not match shape " <> pretty shape <>+      Left $ "Value passed for type parameter " <> quote (prettyName (typeLeaf tn)) <>+      " does not match shape " <> pretty shape <>       " of previously observed value."   | Nothing <- M.lookup (typeLeaf tn) $ envShapes env =       matchValueToType (tnenv <> env) t val@@ -356,7 +356,7 @@       | Just x <- look v ->           if x == arr_n           then continue env-          else emptyOrWrong $ "`" <> pretty v <> "` (" <> pretty x <> ")"+          else emptyOrWrong $ quote (pretty v) <> " (" <> pretty x <> ")"       | otherwise ->           continue $           valEnv (M.singleton (qualLeaf v)@@ -502,7 +502,7 @@ evalTermVar env qv =   case lookupVar qv env of     Just (TermValue _ v) -> return v-    _ -> error $ "`" <> pretty qv <> "` is not bound to a value."+    _ -> error $ quote (pretty qv) <> " is not bound to a value."  -- | Expand type based on information that was not available at -- type-checking time (the structure of abstract types).@@ -564,8 +564,8 @@           case matchValueToType env vt v of             Right _ -> return v             Left err ->-              bad loc env $ "Value `" <> pretty v <>-              "` cannot match type `" <> pretty vt <> "`: " ++ err+              bad loc env $ "Value " <> quote (pretty v) <>+              " cannot match type " <> quote (pretty vt) <> ": " ++ err          isDimParam TypeParamDim{} = True         isDimParam _ = False@@ -625,8 +625,8 @@   let t = evalType env $ unInfo $ expandedType td   case matchValueToType env t v of     Right _ -> return v-    Left err -> bad loc env $ "Value `" <> pretty v <> "` cannot match shape of type `" <>-                pretty (declaredType td) <> "` (`" <> pretty t <> "`): " ++ err+    Left err -> bad loc env $ "Value " <> quote (pretty v) <> " cannot match shape of type " <>+                quote (pretty (declaredType td)) <> " (" <> quote (pretty t) <> "): " ++ err  eval env (LetPat p e body _ _) = do   v <- eval env e@@ -845,7 +845,7 @@ evalModuleVar env qv =   case lookupVar qv env of     Just (TermModule m) -> return m-    _ -> error $ "`" <> pretty qv <> "` is not bound to a module."+    _ -> error $ quote (pretty qv) <> " is not bound to a module."  evalModExp :: Env -> ModExp -> EvalM Module @@ -1006,8 +1006,8 @@           | Just z <- msum $ map (`bopDef'` (x', y')) fs ->               return $ ValuePrim z         _ ->-          bad noLoc mempty $ "Cannot apply operator to arguments `" <>-          pretty x <> "` and `" <> pretty y <> "`."+          bad noLoc mempty $ "Cannot apply operator to arguments " <>+          quote (pretty x) <> " and " <> quote (pretty y) <> "."       where bopDef' (valf, retf, op) (x, y) = do               x' <- valf x               y' <- valf y@@ -1019,8 +1019,8 @@           | Just r <- msum $ map (`unopDef'` x') fs ->               return $ ValuePrim r         _ ->-          bad noLoc mempty $ "Cannot apply function to argument `" <>-          pretty x <> "`."+          bad noLoc mempty $ "Cannot apply function to argument " <>+          quote (pretty x) <> "."       where unopDef' (valf, retf, op) x = do               x' <- valf x               retf =<< op x'@@ -1033,8 +1033,8 @@             Just z <- f x' y' ->               return $ ValuePrim $ putV z         _ ->-          bad noLoc mempty $ "Cannot apply operator to argument `" <>-          pretty v <> "."+          bad noLoc mempty $ "Cannot apply operator to argument " <>+          quote (pretty v) <> "."      def "!" = Just $ unopDef [ (getS, putS, P.doUnOp $ P.Complement Int8)                              , (getS, putS, P.doUnOp $ P.Complement Int16)@@ -1244,7 +1244,15 @@  -- | Execute the named function on the given arguments; will fail -- horribly if these are ill-typed.-interpretFunction :: Ctx -> VName -> [Value] -> F ExtOp Value-interpretFunction ctx fname vs = runEvalM (ctxImports ctx) $ do-  f <- evalTermVar (ctxEnv ctx) $ qualName fname-  foldM (apply noLoc mempty) f vs+interpretFunction :: Ctx -> VName -> [F.Value] -> Either String (F ExtOp Value)+interpretFunction ctx fname vs = do+  vs' <- case mapM convertValue vs of+           Just vs' -> Right vs'+           Nothing -> Left "Invalid input: irregular array."++  Right $ runEvalM (ctxImports ctx) $ do+    f <- evalTermVar (ctxEnv ctx) (qualName fname)+    foldM (apply noLoc mempty) f vs'++  where convertValue (F.PrimValue p) = Just $ ValuePrim p+        convertValue (F.ArrayValue arr _) = mkArray =<< mapM convertValue (elems arr)
src/Language/Futhark/Parser/Parser.y view
@@ -939,19 +939,20 @@                   Left e -> throwError e                   Right v -> return $ ArrayValue (arrayFromList $ $2:$4) $ valueType v              }-           | id '(' PrimType ')'-             {% ($1 `mustBe` "empty") >> return (ArrayValue (listArray (0,-1) []) (Scalar (Prim $3))) }            | id '(' RowType ')'-             {% ($1 `mustBe` "empty") >> return (ArrayValue (listArray (0,-1) []) $3) }+             {% ($1 `mustBe` "empty") >> mustBeEmpty (srcspan $2 $4) $3 >> return (ArrayValue (listArray (0,-1) []) $3) }             -- Errors            | '[' ']'              {% emptyArrayError $1 } -RowType :: { TypeBase () () }-RowType : '[' ']' RowType   { arrayOf $3 (rank 1) Nonunique }-        | '[' ']' PrimType  { arrayOf (Scalar (Prim $3)) (rank 1) Nonunique }+Dim :: { Int32 }+Dim : intlit { let L _ (INTLIT num) = $1 in fromInteger num } +RowType :: { ValueType }+RowType : '[' Dim ']' RowType  { arrayOf $4 (ShapeDecl [$2]) Nonunique }+        | '[' Dim ']' PrimType { arrayOf (Scalar (Prim $4)) (ShapeDecl [$2]) Nonunique }+ Values :: { [Value] } Values : Value ',' Values { $1 : $3 }        | Value            { [$1] }@@ -984,6 +985,12 @@ mustBe (L loc _) expected =   parseErrorAt loc $ Just $   "Only the keyword '" ++ expected ++ "' may appear here."++mustBeEmpty :: SrcLoc -> ValueType -> ParserMonad ()+mustBeEmpty loc (Array _ _ _ (ShapeDecl dims))+  | any (==0) dims = return ()+mustBeEmpty loc t =+  parseErrorAt loc $ Just $ pretty t ++ " is not an empty array."  data ParserEnv = ParserEnv {                  parserFile :: FilePath
src/Language/Futhark/Pretty.hs view
@@ -110,6 +110,9 @@ instance Pretty (ShapeDecl ()) where   ppr (ShapeDecl ds) = mconcat $ replicate (length ds) $ text "[]" +instance Pretty (ShapeDecl Int32) where+  ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds)+ instance Pretty (ShapeDecl dim) => Pretty (ScalarTypeBase dim as) where   ppr = pprPrec 0   pprPrec _ (Prim et) = ppr et
src/Language/Futhark/Syntax.hs view
@@ -33,6 +33,7 @@   , ScalarTypeBase(..)   , PatternType   , StructType+  , ValueType   , Diet(..)   , TypeDeclBase (..) @@ -211,6 +212,8 @@                 deriving Show deriving instance Eq (DimDecl Name) deriving instance Eq (DimDecl VName)+deriving instance Ord (DimDecl Name)+deriving instance Ord (DimDecl VName)  instance Functor DimDecl where   fmap = fmapDefault@@ -381,6 +384,9 @@ -- information, used for declarations. type StructType = TypeBase (DimDecl VName) () +-- | A value type contains full, manifest size information.+type ValueType = TypeBase Int32 ()+ -- | An unstructured type with type variables and possibly shape -- declarations - this is what the user types in the source program. data TypeExp vn = TEVar (QualName vn) SrcLoc@@ -394,6 +400,8 @@                  deriving (Show) deriving instance Eq (TypeExp Name) deriving instance Eq (TypeExp VName)+deriving instance Ord (TypeExp Name)+deriving instance Ord (TypeExp VName)  instance Located (TypeExp vn) where   locOf (TEArray _ _ loc)   = locOf loc@@ -410,6 +418,8 @@                 deriving (Show) deriving instance Eq (TypeArgExp Name) deriving instance Eq (TypeArgExp VName)+deriving instance Ord (TypeArgExp Name)+deriving instance Ord (TypeArgExp VName)  instance Located (TypeArgExp vn) where   locOf (TypeArgExpDim _ loc) = locOf loc@@ -423,6 +433,8 @@                              -- ^ The type deduced by the type checker.            } deriving instance Showable f vn => Show (TypeDeclBase f vn)+deriving instance Eq (TypeDeclBase NoInfo VName)+deriving instance Ord (TypeDeclBase NoInfo VName)  instance Located (TypeDeclBase f vn) where   locOf = locOf . declaredType@@ -441,7 +453,7 @@ -- | Simple Futhark values.  Values are fully evaluated and their type -- is always unambiguous. data Value = PrimValue !PrimValue-           | ArrayValue !(Array Int Value) (TypeBase () ())+           | ArrayValue !(Array Int Value) ValueType              -- ^ It is assumed that the array is 0-indexed.  The type              -- is the full type.              deriving (Eq, Show)@@ -526,6 +538,8 @@                                   (Maybe (ExpBase f vn))                                   (Maybe (ExpBase f vn)) deriving instance Showable f vn => Show (DimIndexBase f vn)+deriving instance Eq (DimIndexBase NoInfo VName)+deriving instance Ord (DimIndexBase NoInfo VName)  -- | A name qualified with a breadcrumb of module accesses. data QualName vn = QualName { qualQuals :: ![vn]@@ -663,8 +677,9 @@              | Match (ExpBase f vn) (NE.NonEmpty (CaseBase f vn)) (f PatternType) SrcLoc             -- ^ A match expression.- deriving instance Showable f vn => Show (ExpBase f vn)+deriving instance Eq (ExpBase NoInfo VName)+deriving instance Ord (ExpBase NoInfo VName)  instance Located (ExpBase f vn) where   locOf (Literal _ loc)                = locOf loc@@ -704,8 +719,9 @@ -- | An entry in a record literal. data FieldBase f vn = RecordFieldExplicit Name (ExpBase f vn) SrcLoc                     | RecordFieldImplicit vn (f PatternType) SrcLoc- deriving instance Showable f vn => Show (FieldBase f vn)+deriving instance Eq (FieldBase NoInfo VName)+deriving instance Ord (FieldBase NoInfo VName)  instance Located (FieldBase f vn) where   locOf (RecordFieldExplicit _ _ loc) = locOf loc@@ -713,8 +729,9 @@  -- | A case in a match expression. data CaseBase f vn = CasePat (PatternBase f vn) (ExpBase f vn) SrcLoc- deriving instance Showable f vn => Show (CaseBase f vn)+deriving instance Eq (CaseBase NoInfo VName)+deriving instance Ord (CaseBase NoInfo VName)  instance Located (CaseBase f vn) where   locOf (CasePat _ _ loc) = locOf loc@@ -724,6 +741,8 @@                        | ForIn (PatternBase f vn) (ExpBase f vn)                        | While (ExpBase f vn) deriving instance Showable f vn => Show (LoopFormBase f vn)+deriving instance Eq (LoopFormBase NoInfo VName)+deriving instance Ord (LoopFormBase NoInfo VName)  -- | A pattern as used most places where variables are bound (function -- parameters, @let@ expressions, etc).@@ -736,6 +755,8 @@                       | PatternLit (ExpBase f vn) (f PatternType) SrcLoc                       | PatternConstr Name (f PatternType) [PatternBase f vn] SrcLoc deriving instance Showable f vn => Show (PatternBase f vn)+deriving instance Eq (PatternBase NoInfo VName)+deriving instance Ord (PatternBase NoInfo VName)  instance Located (PatternBase f vn) where   locOf (TuplePattern _ loc)        = locOf loc@@ -799,7 +820,7 @@                         -- ^ A type parameter that must be a size.                       | TypeParamType Liftedness vn SrcLoc                         -- ^ A type parameter that must be a type.-  deriving (Eq, Show)+  deriving (Eq, Ord, Show)  instance Functor TypeParamBase where   fmap = fmapDefault
src/Language/Futhark/TypeChecker/Monad.hs view
@@ -28,7 +28,6 @@   , MonadTypeChecker(..)   , checkName   , badOnLeft-  , quote    , module Language.Futhark.Warnings @@ -192,7 +191,7 @@     "\nwith\n" ++ indent (pretty t2)     where indent = intercalate "\n" . map ("  "++) . lines   show (MatchingFields field) =-    "When matching types of record field `" ++ pretty field ++ "`."+    "When matching types of record field " ++ quote (pretty field) ++ "."  -- | Tracking breadcrumbs to give a kind of "stack trace" in errors. class Monad m => MonadBreadCrumbs m where@@ -356,12 +355,6 @@  badOnLeft :: MonadTypeChecker m => Either TypeError a -> m a badOnLeft = either throwError return---- | Enclose a string in the prefered quotes used in error messages.--- These are picked to not collide with characters permitted in--- identifiers.-quote :: String -> String-quote s = "`" ++ s ++ "`"  anySignedType :: [PrimType] anySignedType = map Signed [minBound .. maxBound]
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -223,7 +223,7 @@   newTypeVar loc desc = do     i <- incCounter     v <- newID $ mkTypeVarName desc i-    modifyConstraints $ M.insert v $ NoConstraint Nothing $ mkUsage' loc+    modifyConstraints $ M.insert v $ NoConstraint Lifted $ mkUsage' loc     return $ Scalar $ TypeVar mempty Nonunique (typeName v) []  instance MonadBreadCrumbs TermTypeM where@@ -423,7 +423,7 @@ instantiateTypeParam loc tparam = do   i <- incCounter   v <- newID $ mkTypeVarName (takeWhile isAlpha (baseString (typeParamName tparam))) i-  modifyConstraints $ M.insert v $ NoConstraint (Just l) $ mkUsage' loc+  modifyConstraints $ M.insert v $ NoConstraint l $ mkUsage' loc   return (v, Subst $ Scalar $ TypeVar mempty Nonunique (typeName v) [])   where l = case tparam of TypeParamType x _ _ -> x                            _                   -> Lifted@@ -431,7 +431,7 @@ newArrayType :: SrcLoc -> String -> Int -> TermTypeM (TypeBase () (), TypeBase () ()) newArrayType loc desc r = do   v <- newID $ nameFromString desc-  modifyConstraints $ M.insert v $ NoConstraint Nothing $ mkUsage' loc+  modifyConstraints $ M.insert v $ NoConstraint Unlifted $ mkUsage' loc   let rowt = TypeVar () Nonunique (typeName v) []   return (Array () Nonunique rowt (ShapeDecl $ replicate r ()),           Scalar rowt)@@ -1243,6 +1243,7 @@     convergePattern pat body_cons body_t body_loc = do       let consumed_merge = S.map identName (patternIdents pat) `S.intersection`                            body_cons+           uniquePat (Wildcard (Info t) wloc) =             Wildcard (Info $ t `setUniqueness` Nonunique) wloc           uniquePat (PatternParens p ploc) =@@ -1280,40 +1281,68 @@       -- Check that the new values of consumed merge parameters do not       -- alias something bound outside the loop, AND that anything       -- returned for a unique merge parameter does not alias anything-      -- else returned.+      -- else returned.  We also update the aliases for the pattern.       bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope-      let checkMergeReturn (Id pat_v (Info pat_v_t) _) t+      let combAliases t1 t2 =+            case t1 of Scalar Record{} -> t1+                       _ -> t1 `addAliases` (<>aliases t2)++          checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t             | unique pat_v_t,-              v:_ <- S.toList $ S.map aliasVar (aliases t) `S.intersection` bound_outside =-                lift $ typeError loc $ "Loop return value corresponding to merge parameter " +++              v:_ <- S.toList $+                     S.map aliasVar (aliases t) `S.intersection` bound_outside =+                lift $ typeError loc $+                "Loop return value corresponding to merge parameter " ++                 quote (prettyName pat_v) ++ " aliases " ++ prettyName v ++ "."+             | otherwise = do                 (cons,obs) <- get                 unless (S.null $ aliases t `S.intersection` cons) $-                  lift $ typeError loc $ "Loop return value for merge parameter " ++-                  quote (prettyName pat_v) ++ " aliases other consumed merge parameter."+                  lift $ typeError loc $+                  "Loop return value for merge parameter " +++                  quote (prettyName pat_v) +++                  " aliases other consumed merge parameter."                 when (unique pat_v_t &&                       not (S.null (aliases t `S.intersection` (cons<>obs)))) $-                  lift $ typeError loc $ "Loop return value for consuming merge parameter " +++                  lift $ typeError loc $+                  "Loop return value for consuming merge parameter " ++                   quote (prettyName pat_v) ++ " aliases previously returned value."                 if unique pat_v_t                   then put (cons<>aliases t, obs)                   else put (cons, obs<>aliases t)++                return $ Id pat_v (Info (combAliases pat_v_t t)) patloc++          checkMergeReturn (Wildcard (Info pat_v_t) patloc) t =+            return $ Wildcard (Info (combAliases pat_v_t t)) patloc+           checkMergeReturn (PatternParens p _) t =             checkMergeReturn p t+           checkMergeReturn (PatternAscription p _ _) t =             checkMergeReturn p t-          checkMergeReturn (RecordPattern pfs _) (Scalar (Record tfs)) =-            sequence_ $ M.elems $ M.intersectionWith checkMergeReturn (M.fromList pfs) tfs-          checkMergeReturn (TuplePattern pats _) t | Just ts <- isTupleRecord t =-            zipWithM_ checkMergeReturn pats ts-          checkMergeReturn _ _ =-            return ()-      (pat_cons, _) <- execStateT (checkMergeReturn pat' body_t') (mempty, mempty)++          checkMergeReturn (RecordPattern pfs patloc) (Scalar (Record tfs)) =+            RecordPattern . M.toList <$> sequence pfs' <*> pure patloc+            where pfs' = M.intersectionWith checkMergeReturn+                         (M.fromList pfs) tfs++          checkMergeReturn (TuplePattern pats patloc) t+            | Just ts <- isTupleRecord t =+                TuplePattern+                <$> zipWithM checkMergeReturn pats ts+                <*> pure patloc++          checkMergeReturn p _ =+            return p++      (pat'', (pat_cons, _)) <-+        runStateT (checkMergeReturn pat' body_t') (mempty, mempty)+       let body_cons' = body_cons <> S.map aliasVar pat_cons-      if body_cons' == body_cons && patternType pat' == patternType pat+      if body_cons' == body_cons && patternType pat'' == patternType pat         then return pat'-        else convergePattern pat' body_cons' body_t' body_loc+        else convergePattern pat'' body_cons' body_t' body_loc  checkExp (Constr name es NoInfo loc) = do   t <- newTypeVar loc "t"@@ -1994,7 +2023,7 @@         closeOver (k, _)           | k `elem` map typeParamName tparams =               return Nothing-        closeOver (k, NoConstraint (Just Unlifted) usage) =+        closeOver (k, NoConstraint Unlifted usage) =           return $ Just $ TypeParamType Unlifted k $ srclocOf usage         closeOver (k, NoConstraint _ usage) =           return $ Just $ TypeParamType Lifted k $ srclocOf usage
src/Language/Futhark/TypeChecker/Types.hs view
@@ -120,7 +120,7 @@   case ps of     [] -> return (TEVar name' loc, t, l)     _  -> throwError $ TypeError loc $-          "Type constructor " ++ pretty name ++ " used without any arguments."+          "Type constructor " ++ quote (pretty name) ++ " used without any arguments." checkTypeExp (TETuple ts loc) = do   (ts', ts_s, ls) <- unzip3 <$> mapM checkTypeExp ts   return (TETuple ts' loc, tupleRecord ts_s, foldl' max Unlifted ls)@@ -143,7 +143,7 @@   case (l, arrayOf st (ShapeDecl [d']) Nonunique) of     (Unlifted, st') -> return (TEArray t' d' loc, st', Unlifted)     _ -> throwError $ TypeError loc $-         "Cannot create array with elements of type `" ++ pretty st ++ "` (might be functional)."+         "Cannot create array with elements of type " ++ quote (pretty st) ++ " (might be functional)."   where checkDimDecl AnyDim =           return AnyDim         checkDimDecl (ConstDim k) =@@ -153,7 +153,7 @@ checkTypeExp (TEUnique t loc) = do   (t', st, l) <- checkTypeExp t   unless (mayContainArray st) $-    warn loc $ "Declaring `" <> pretty st <> "` as unique has no effect."+    warn loc $ "Declaring " <> quote (pretty st) <> " as unique has no effect."   return (TEUnique t' loc, st `setUniqueness` Unique, l)   where mayContainArray (Scalar Prim{}) = False         mayContainArray Array{} = True@@ -290,15 +290,15 @@               pos_uses' = pos <> pos_uses           forM_ neg $ \pv ->             unless ((pv `notElem` tp_names) || (pv `elem` pos_uses')) $-            throwError $ TypeError (srclocOf p) $ "Shape parameter `" ++-            pretty (baseName pv) ++ "` must first be given in " +++            throwError $ TypeError (srclocOf p) $ "Shape parameter " +++            quote (prettyName pv) ++ " must first be given in " ++             "a positive position (non-functional parameter)."           return pos_uses'         checkUsed uses (TypeParamDim pv loc)           | pv `elem` uses = return ()           | otherwise =-              throwError $ TypeError loc $ "Size parameter `" ++-              pretty (baseName pv) ++ "` unused."+              throwError $ TypeError loc $ "Size parameter " +++              quote (prettyName pv) ++ " unused."         checkUsed _ _ = return ()  checkTypeParams :: MonadTypeChecker m =>
src/Language/Futhark/TypeChecker/Unify.hs view
@@ -59,7 +59,7 @@ instance Located Usage where   locOf (Usage _ loc) = locOf loc -data Constraint = NoConstraint (Maybe Liftedness) Usage+data Constraint = NoConstraint Liftedness Usage                 | ParamType Liftedness SrcLoc                 | Constraint (TypeBase () ()) Usage                 | Overloaded [PrimType] Usage@@ -218,7 +218,7 @@             modifyConstraints $ M.map $ applySubstInConstraint vn $ Subst tp'             case M.lookup vn constraints of -              Just (NoConstraint (Just Unlifted) unlift_usage) ->+              Just (NoConstraint Unlifted unlift_usage) ->                 zeroOrderType usage (show unlift_usage) tp'                Just (Equality _) ->@@ -350,6 +350,8 @@               modifyConstraints $ M.insert vn (Equality usage)             Just (Overloaded _ _) ->               return () -- All primtypes support equality.+            Just Equality{} ->+              return ()             Just (HasConstrs cs _) ->               mapM_ (equalityType usage) $ concat $ M.elems cs             _ ->@@ -372,7 +374,7 @@                 " must be non-function, but inferred to be " ++                 quote (pretty vn_t) ++ " due to " ++ show old_usage ++ "."             Just (NoConstraint _ _) ->-              modifyConstraints $ M.insert vn (NoConstraint (Just Unlifted) usage)+              modifyConstraints $ M.insert vn (NoConstraint Unlifted usage)             Just (ParamType Lifted ploc) ->               typeError usage $ "Type " ++ desc ++               " must be non-function, but type parameter " ++ quote (prettyName vn) ++ " at " ++@@ -432,7 +434,7 @@           return t'       | otherwise ->           typeError usage $-          "Attempt to access field " ++ quote (pretty l) ++ "` of value of type " +++          "Attempt to access field " ++ quote (pretty l) ++ " of value of type " ++           quote (pretty (toStructural t)) ++ "."     _ -> do unify usage (toStructural t) $ Scalar $ Record $ M.singleton l l_type'             return l_type@@ -455,7 +457,7 @@             put (x, i+1)             return i     let v = VName (mkTypeVarName desc i) 0-    modifyConstraints $ M.insert v $ NoConstraint Nothing $ Usage Nothing loc+    modifyConstraints $ M.insert v $ NoConstraint Lifted $ Usage Nothing loc     return $ Scalar $ TypeVar mempty Nonunique (typeName v) []  -- | Construct a the name of a new type variable given a base@@ -483,4 +485,4 @@ runUnifyM tparams (UnifyM m) = runExcept $ evalStateT m (constraints, 0)   where constraints = M.fromList $ mapMaybe f tparams         f TypeParamDim{} = Nothing-        f (TypeParamType l p loc) = Just (p, NoConstraint (Just l) $ Usage Nothing loc)+        f (TypeParamType l p loc) = Just (p, NoConstraint l $ Usage Nothing loc)
src/futhark.hs view
@@ -8,6 +8,7 @@ import Data.List import qualified Data.Text as T import qualified Data.Text.IO as T+import GHC.IO.Encoding (setLocaleEncoding) import System.IO import System.Exit import System.Environment@@ -96,6 +97,7 @@ main = reportingIOErrors $ do   hSetEncoding stdout utf8   hSetEncoding stderr utf8+  setLocaleEncoding utf8   args <- getArgs   prog <- getProgName   case args of