Specially handle short strings in the parser

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