git.iko.soy/elk
on master help sign in
Add in more extensive escaping for GLSL shaders

Fixes https://github.com/elm/compiler/issues/1923 This should allocate a bit less during parsing by skipping a (Utf8 SHADER_STRING) and going directly to [Char] which is needed for Language.GLSL.Parser. It should then be stored as a ByteString which will keep *.elmo files alive longer during code gen. It means there is less memory traffic that relates to GC, but at the cost of using pinned memory for longer. Again, I think this is okay / in a desirable direction.

commitb522c7f6b00859b98eda6d1b02875db0651ab4a4 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 3 Jun 2019, 11:50 (7 years ago) parent2975803
2 files changed+64−17
compare with master
unifiedsplit
compiler/src/AST/Utils/Shader.hs+49−4 compiler/src/Parse/Shader.hs+15−13
compiler/src/AST/Utils/Shader.hs+49−4
@@ -4,22 +4,27 @@ module AST.Utils.Shader
44 ( Source
55 , Types(..)
66 , Type(..)
7+ , fromChars
8+ , toJsStringBuilder
79 )
810 where
911
1012
13+import Control.Monad (liftM)
14+import Data.Binary (Binary, get, put)
15+import qualified Data.ByteString as BS
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.ByteString.UTF8 as BS_UTF8
1118import qualified Data.Map as Map
1219import qualified Data.Name as Name
13−import qualified Data.Utf8 as Utf8
1420
1521
1622
1723-- SOURCE
1824
1925
20−type Source = Utf8.VeryLong SOURCE
21−
22−data SOURCE
26+newtype Source =
27+ Source BS.ByteString
2328
2429
2530
@@ -42,3 +47,43 @@ data Type
4247 | V4
4348 | M4
4449 | Texture
50+
51+
52+
53+-- TO BUILDER
54+
55+
56+toJsStringBuilder :: Source -> B.Builder
57+toJsStringBuilder (Source src) =
58+ B.byteString src
59+
60+
61+
62+-- FROM CHARS
63+
64+
65+fromChars :: [Char] -> Source
66+fromChars chars =
67+ Source (BS_UTF8.fromString (escape chars))
68+
69+
70+escape :: [Char] -> [Char]
71+escape chars =
72+ case chars of
73+ [] ->
74+ []
75+
76+ c:cs
77+ | c == '\n' -> '\\' : 'n' : escape cs
78+ | c == '\"' -> '\\' : '"' : escape cs
79+ | c == '\'' -> '\\' : '\'' : escape cs
80+ | otherwise -> c : escape cs
81+
82+
83+
84+-- BINARY
85+
86+
87+instance Binary Source where
88+ get = liftM Source get
89+ put (Source a) = put a
compiler/src/Parse/Shader.hs+15−13
@@ -6,12 +6,13 @@ module Parse.Shader
66 where
77
88
9−import qualified Data.List as List
9+import qualified Data.ByteString.Internal as B
10+import qualified Data.ByteString.UTF8 as BS_UTF8
1011import qualified Data.Map as Map
1112import qualified Data.Name as Name
12−import qualified Data.Utf8 as Utf8
1313import Data.Word (Word8)
14−import Foreign.Ptr (Ptr, plusPtr)
14+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
15+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
1516import qualified Language.GLSL.Parser as GLP
1617import qualified Language.GLSL.Syntax as GLS
1718import qualified Text.Parsec as Parsec
@@ -32,16 +33,16 @@ import qualified Reporting.Error.Syntax as E
3233shader :: A.Position -> Parser E.Expr Src.Expr
3334shader start@(A.Position row col) =
3435 do block <- parseBlock
35− shdr <- parseGlsl row col src
36+ shdr <- parseGlsl row col block
3637 end <- P.getPosition
37− return (A.at start end (Src.Shader (Shader.fromChars src) shdr))
38+ return (A.at start end (Src.Shader (Shader.fromChars block) shdr))
3839
3940
4041
4142-- BLOCK
4243
4344
44−parseBlock :: Parser E.Expr P.Snippet
45+parseBlock :: Parser E.Expr [Char]
4546parseBlock =
4647 P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
4748 let
@@ -62,11 +63,12 @@ parseBlock =
6263 case status of
6364 Good ->
6465 let
65− !block = Utf8.fromPtr pos6 newPos
66− !source = Utf8.toChars block
66+ !off = minusPtr pos6 (unsafeForeignPtrToPtr src)
67+ !len = minusPtr newPos pos6
68+ !block = BS_UTF8.toString (B.PS src off len)
6769 !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)
6870 in
69− cok source newState
71+ cok block newState
7072
7173 Unending ->
7274 cerr row col E.EndlessShader
@@ -102,7 +104,7 @@ eatShader pos end row col =
102104-- GLSL
103105
104106
105−parseGlsl :: Row -> Col -> String -> Parser E.Expr Shader.Types
107+parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types
106108parseGlsl startRow startCol src =
107109 case GLP.parse src of
108110 Right (GLS.TranslationUnit decls) ->
@@ -127,7 +129,7 @@ parseGlsl startRow startCol src =
127129 else failure (startRow + row - 1) col msg
128130
129131
130−failure :: Row -> Col -> String -> Parser E.Expr a
132+failure :: Row -> Col -> [Char] -> Parser E.Expr a
131133failure row col msg =
132134 P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->
133135 cerr row col (E.ShaderProblem msg)
@@ -142,7 +144,7 @@ emptyTypes =
142144 Shader.Types Map.empty Map.empty Map.empty
143145
144146
145−addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types
147+addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types
146148addInput (qual, tipe, name) glDecls =
147149 case qual of
148150 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
@@ -151,7 +153,7 @@ addInput (qual, tipe, name) glDecls =
151153 _ -> error "Should never happen due to `extractInputs` function"
152154
153155
154−extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)]
156+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]
155157extractInputs decl =
156158 case decl of
157159 GLS.Declaration