Specially handle short strings in the parser (#475)

* Specially handle short strings in the parser

These short strings are read using the appropriate
constructor, rather than the general buffer
constructor.  So the empty and singleton
constructors are now public.

Other changes include optimising foreign lpvm cast
instructions applied to constant chars, integers
and floats, as they get generated in this case.
This avoids several instructions in calling
unboxed constructors with constant arguments.

Also use the -n wybemk flag in final-dump-test.sh,
to turn off colourising, making diffs easier to
read.

There are numerous code improvements in final dump
tests, including allowing specialisation to kick
in in many places, since unboxed values cannot be
aliased.

There's one unfortunate change in output for
constant_type_constraint_error.wybe: the error
message for ?a = "s":int now complains about a
type error in the call to wybe.string.singleton,
which doesn't appear on the line. I think this is
tolerable for now, as it would be difficult to
fix.

Closes #473

* Address all review comments

Author: pschachte

WYBE.md

@@ -2245,38 +2245,46 @@ Floating point multiplication
 Floating point division
 - `foreign llvm frem(`arg1:float, arg2:float`)`:float
 Floating point remainder
-- `foreign llvm fcmp_ord(`arg1:float, arg2:float`)`:bool
-Floating point ordered (neither is a NaN)
+
+
+##### Floating point comparisons
+
+Floating point comparisons are either *ordered* or *unordered*, the former
+returning false if either comparand is not a number (NaN), while the latter sort
+return true in that case.
+
+- `foreign llvm fcmp_false(`arg1:float, arg2:float`)`:bool
+Always returns false with no comparison
 - `foreign llvm fcmp_oeq(`arg1:float, arg2:float`)`:bool
 Floating point equality
-- `foreign llvm fcmp_one(`arg1:float, arg2:float`)`:bool
-Floating point disequality
-- `foreign llvm fcmp_olt(`arg1:float, arg2:float`)`:bool
-Floating point (signed) strictly less
-- `foreign llvm fcmp_ole(`arg1:float, arg2:float`)`:bool
-Floating point (signed) less or equal
 - `foreign llvm fcmp_ogt(`arg1:float, arg2:float`)`:bool
-Floating point (signed) strictly greater
+Floating point strictly greater
 - `foreign llvm fcmp_oge(`arg1:float, arg2:float`)`:bool
-Floating point (signed) greater or equal
+Floating point greater or equal
+- `foreign llvm fcmp_olt(`arg1:float, arg2:float`)`:bool
+Floating point strictly less
+- `foreign llvm fcmp_ole(`arg1:float, arg2:float`)`:bool
+Floating point less or equal
+- `foreign llvm fcmp_one(`arg1:float, arg2:float`)`:bool
+Floating point disequality
 - `foreign llvm fcmp_ord(`arg1:float, arg2:float`)`:bool
-Floating point unordered (either is a NaN)
+Floating point ordered (neither is a NaN)
 - `foreign llvm fcmp_ueq(`arg1:float, arg2:float`)`:bool
 Floating point unordered or equal
-- `foreign llvm fcmp_une(`arg1:float, arg2:float`)`:bool
-Floating point unordered or not equal
-- `foreign llvm fcmp_ult(`arg1:float, arg2:float`)`:bool
-Floating point unordered or strictly less
-- `foreign llvm fcmp_ule(`arg1:float, arg2:float`)`:bool
-Floating point unordered or less or equal
 - `foreign llvm fcmp_ugt(`arg1:float, arg2:float`)`:bool
 Floating point unordered or strictly greater
 - `foreign llvm fcmp_uge(`arg1:float, arg2:float`)`:bool
 Floating point unordered or greater or equal
+- `foreign llvm fcmp_ult(`arg1:float, arg2:float`)`:bool
+Floating point unordered or strictly less
+- `foreign llvm fcmp_ule(`arg1:float, arg2:float`)`:bool
+Floating point unordered or less or equal
+- `foreign llvm fcmp_une(`arg1:float, arg2:float`)`:bool
+Floating point unordered or not equal
+- `foreign llvm fcmp_uno(`arg1:float, arg2:float`)`:bool
+Floating point unordered (either is a NaN)
 - `foreign llvm fcmp_true(`arg1:float, arg2:float`)`:bool
 Always returns true with no comparison
-- `foreign llvm fcmp_false(`arg1:float, arg2:float`)`:bool
-Always returns false with no comparison
 
 #####  <a name="conversion"></a>Integer/floating point conversion
 
@@ -2309,7 +2317,7 @@ treat this as an ordinary pointer.
 - `opaque`
 the type is a machine address, similar to the `void *` type in C.  Wybe treats such values as opaque.
 - *n* `bit signed`
-a signed primitive number type comprising *n* bits, where *n* is any non-negative
+a signed primitive number type comprising *n* bits, where *n* is any positive
 integer.  Represents integers between -2<sup>*n*-1</sup> and 2<sup>*n*-1</sup>-1 inclusive.
 - *n* `bit unsigned`
 an unsigned primitive number type comprising *n* bits, where *n* is any non-negative

src/BodyBuilder.hs

@@ -19,6 +19,7 @@ import Snippets ( boolType, intType, primMove )
 import Util
 import Config (minimumSwitchCases, wordSize)
 import Options (LogSelection(BodyBuilder))
+import Data.Char ( ord )
 import Data.Map as Map
 import Data.List as List
 import Data.Set as Set
@@ -234,11 +235,6 @@ instance Show Constraint where
         = show v ++ ":" ++ show t ++ " ~= " ++ show a
 
 
--- negateConstraint :: Constraint -> Constraint
--- negateConstraint (Equal v n)    = NotEqual v n
--- negateConstraint (NotEqual v n) = Equal v n
-
-
 ----------------------------------------------------------------
 --                      BodyBuilder Primitive Operations
 ----------------------------------------------------------------
@@ -954,6 +950,7 @@ updateVariableFlows prim = do
 --  performing the operation at compile-time.
 simplifyForeign ::  String -> ProcName -> [Ident] -> [PrimArg] -> Prim
 simplifyForeign "llvm" op flags args = simplifyOp op flags args
+simplifyForeign "lpvm" op flags args = simplifyLPVM op flags args
 simplifyForeign lang op flags args = PrimForeign lang op flags args
 
 
@@ -1130,21 +1127,53 @@ simplifyOp "fdiv" _ [ArgFloat n1 ty, ArgFloat n2 _, output] =
 simplifyOp "fdiv" _ [arg, ArgFloat 1 _, output] =
   primMove arg output
 -- Float comparisons
+simplifyOp "fcmp_false" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant False) output
 simplifyOp "fcmp_oeq" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
   primMove (boolConstant $ n1==n2) output
-simplifyOp "fcmp_one" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
-  primMove (boolConstant $ n1/=n2) output
+simplifyOp "fcmp_ogt" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1>n2) output
+simplifyOp "fcmp_oge" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1>=n2) output
 simplifyOp "fcmp_olt" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
   primMove (boolConstant $ n1<n2) output
 simplifyOp "fcmp_ole" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
   primMove (boolConstant $ n1<=n2) output
-simplifyOp "fcmp_ogt" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+simplifyOp "fcmp_one" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1/=n2) output
+simplifyOp "fcmp_ord" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant True) output
+simplifyOp "fcmp_ueq" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1==n2) output
+simplifyOp "fcmp_ugt" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
   primMove (boolConstant $ n1>n2) output
-simplifyOp "fcmp_oge" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+simplifyOp "fcmp_uge" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
   primMove (boolConstant $ n1>=n2) output
+simplifyOp "fcmp_ult" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1<n2) output
+simplifyOp "fcmp_ule" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1<=n2) output
+simplifyOp "fcmp_une" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant $ n1/=n2) output
+simplifyOp "fcmp_uno" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant False) output
+simplifyOp "fcmp_true" _ [ArgFloat n1 _, ArgFloat n2 _, output] =
+  primMove (boolConstant True) output
 simplifyOp name flags args = PrimForeign "llvm" name flags args
 
 
+-- | Simplify and canonicalise llpm instructions where possible.  For now, this only 
+--   handles cast instructions for constants.
+simplifyLPVM :: ProcName -> [Ident] -> [PrimArg] -> Prim
+simplifyLPVM "cast" _ [ArgInt n _, output] =
+  primMove (ArgInt n (argType output)) output
+simplifyLPVM "cast" _ [ArgChar ch _, output] =
+  primMove (ArgInt (fromIntegral $ ord ch) (argType output)) output
+simplifyLPVM "cast" _ [ArgFloat n _, output] =
+  primMove (ArgFloat n (argType output)) output
+simplifyLPVM name flags args = PrimForeign "lpvm" name flags args
+
+
 boolConstant :: Bool -> PrimArg
 boolConstant bool = ArgInt (fromIntegral $ fromEnum bool) boolType
 

src/Expansion.hs

@@ -27,6 +27,8 @@ import           Data.Map                  as Map
 import           Data.Set                  as Set
 import           Data.Maybe                as Maybe
 import           Options                   (LogSelection (Expansion))
+import Distribution.Simple.Setup (emptyGlobalFlags)
+import Snippets
 
 
 -- | Expand the supplied ProcDef, inlining as desired.
@@ -169,6 +171,15 @@ addRenaming var val = do
 -- are used to tell which variables shoudn't be renamed.
 
 
+-- | Generate a fresh CallSiteID.
+genCallSiteID :: Expander CallSiteID
+genCallSiteID = do
+    id <- gets nextCallSiteID
+    modify (\st -> st {nextCallSiteID = id + 1})
+    return id
+
+
+-- | Add an instruction to the body, possibly renaming variables
 addInstr :: Prim -> OptPos -> Expander ()
 addInstr prim pos = do
     -- reassign "CallSiteID" if the given prim is inlined from other proc
@@ -177,8 +188,7 @@ addInstr prim pos = do
             inlinePos <- gets inlining
             if isJust inlinePos
             then do
-                callSiteID <- gets nextCallSiteID
-                modify (\st -> st {nextCallSiteID = callSiteID + 1})
+                callSiteID <- genCallSiteID
                 return $ PrimCall callSiteID pspec impurity args gFlows
             else
                 return prim
@@ -332,6 +342,34 @@ inlineCall proto args body pos = do
 
 
 expandArg :: PrimArg -> Expander PrimArg
+-- termToExp (StringConst pos "" DoubleQuote)
+--     = return $ Placed (Fncall ["wybe","string"] "empty" False []) pos
+-- termToExp (StringConst pos [chr] DoubleQuote)
+--     = return $ Placed (Fncall ["wybe","string"] "singleton" False
+--                         [Unplaced (CharValue chr)]) pos
+expandArg arg@(ArgString "" WybeString ty) = do
+    logExpansion "Optimising empty string"
+    newVarName <- lift freshVarName
+    let defVar = ArgVar newVarName ty FlowOut Ordinary False
+    let useVar = ArgVar newVarName ty FlowIn Ordinary False
+    logExpansion $ "    Generated fresh name " ++ show newVarName
+    callID <- genCallSiteID
+    let emptyStringProc = ProcSpec ["wybe","string"] "empty" 0 Set.empty
+    expandPrim (PrimCall callID emptyStringProc Pure [defVar] emptyGlobalFlows) Nothing
+    logExpansion $ "Empty string variable = " ++ show useVar
+    return useVar
+expandArg arg@(ArgString [ch] WybeString ty) = do
+    logExpansion $ "Optimising singleton string \"" ++ [ch] ++ "\""
+    newVarName <- lift freshVarName
+    let defVar = ArgVar newVarName ty FlowOut Ordinary False
+    let useVar = ArgVar newVarName ty FlowIn Ordinary False
+    logExpansion $ "    Generated fresh name " ++ show newVarName
+    callID <- genCallSiteID
+    let emptyStringProc = ProcSpec ["wybe","string"] "singleton" 0 Set.empty
+    expandPrim (PrimCall callID emptyStringProc Pure
+                [ArgChar ch charType, defVar] emptyGlobalFlows) Nothing
+    logExpansion $ "Singleton string variable = " ++ show useVar
+    return useVar
 expandArg arg@(ArgVar var ty flow ft _) = do
     renameAll <- isJust <$> gets inlining
     if renameAll

src/Parser.hs

@@ -171,7 +171,7 @@ typeRep = do
 -- | Type declaration body where visibility, constructors, and items are given
 typeCtors :: Parser (TypeImpln,[Item])
 typeCtors = betweenB Brace $ do
-    vis <- option Private 
+    vis <- option Private
         $ try (visibility <* (ident "constructor" <|> ident "constructors"))
     ctors <- TypeCtors vis <$> ctorDecls
     items <- option [] (separator *> items)
@@ -260,7 +260,7 @@ procOrFuncItem vis = do
                 Nothing -> do
                     body <- embracedTerm >>= parseWith termToBody
                     return $ ProcDecl vis mods proto' body $ Just pos
-        
+
 
 
 -- | Parse an optional series of resource flows
@@ -1171,9 +1171,9 @@ termToExp (Call pos [] "@" flow exps) = do
     exps' <- mapM termToExp exps
     case content <$> exps' of
         [] -> return $ Placed (AnonParamVar Nothing flow) pos
-        [IntValue i] | i > 0 
+        [IntValue i] | i > 0
             -> return $ Placed (AnonParamVar (Just i) flow) pos
-        [exp] 
+        [exp]
             -> return $ Placed (AnonFunc $ head exps') pos
         _ -> syntaxError pos "invalid anonymous parameter/function expression"
 termToExp (Call pos [] "|" ParamIn [exp1,exp2]) = do

src/Snippets.hs

@@ -7,7 +7,7 @@
 
 module Snippets (castFromTo, castTo, withType, intType, intCast,
                  tagType, tagCast, phantomType, stringType, cStringType,
-                 isTypeVar,
+                 charType, isTypeVar,
                  varSet, varGet, varGetSet,
                  varSetTyped, varGetTyped, varGetSetTyped,
                  boolType, boolCast, boolTrue, boolFalse, boolBool,
@@ -84,6 +84,10 @@ stringType = TypeSpec ["wybe"] "string" []
 cStringType :: TypeSpec
 cStringType = TypeSpec ["wybe"] "c_string" []
 
+-- | The char type, a single character constant
+charType :: TypeSpec
+charType = TypeSpec ["wybe"] "char" []
+
 -- | Is the given string a type variable name
 isTypeVar :: String -> Bool
 isTypeVar (alpha:digits) | isUpper alpha && all isDigit digits = True

src/Types.hs

@@ -1219,10 +1219,9 @@ typecheckProcDecl' pdef = do
                         typeError $ ReasonUndef name callee $ place pcall
                     _ -> shouldnt "typecheckProcDecl'"
                 ) badCalls
-            ifOK pdef $ do
-                typecheckCalls calls' [] False
-                    $ List.filter (isForeign . content) calls
-                ifOK pdef $ modeCheckProcDecl pdef
+            typecheckCalls calls' [] False
+                $ List.filter (isForeign . content) calls
+            ifOK pdef $ modeCheckProcDecl pdef
 
 
 -- | If no type errors have been recorded, execute the enclosed code; otherwise