1{-# OPTIONS_GHC -Wall #-} 2{-# LANGUAGE OverloadedStrings #-} 3module AST.Canonical 4 ( Expr, Expr_(..) 5 , CaseBranch(..) 6 , FieldUpdate(..) 7 , CtorOpts(..) 8 -- definitions 9 , Def(..) 10 , Decls(..) 11 -- patterns 12 , Pattern, Pattern_(..) 13 , PatternCtorArg(..) 14 -- types 15 , Annotation(..) 16 , Type(..) 17 , AliasType(..) 18 , FieldType(..) 19 , fieldsToList 20 -- modules 21 , Module(..) 22 , Alias(..) 23 , Binop(..) 24 , Union(..) 25 , Ctor(..) 26 , Exports(..) 27 , Export(..) 28 , Effects(..) 29 , Port(..) 30 , Manager(..) 31 ) 32 where 33 34{- Creating a canonical AST means finding the home module for all variables. 35So if you have L.map, you need to figure out that it is from the elm/core 36package in the List module. 37 38In later phases (e.g. type inference, exhaustiveness checking, optimization) 39you need to look up additional info from these modules. What is the type? 40What are the alternative type constructors? These lookups can be quite costly, 41especially in type inference. To reduce costs the canonicalization phase 42caches info needed in later phases. This means we no longer build large 43dictionaries of metadata with O(log(n)) lookups in those phases. Instead 44there is an O(1) read of an existing field! I have tried to mark all 45cached data with comments like: 46 47-- CACHE for exhaustiveness 48-- CACHE for inference 49 50So it is clear why the data is kept around. 51-} 52 53 54import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM) 55import Data.Binary 56import qualified Data.List as List 57import qualified Data.Map as Map 58import Data.Name (Name) 59 60import qualified AST.Source as Src 61import qualified AST.Utils.Binop as Binop 62import qualified AST.Utils.Shader as Shader 63import qualified Data.Index as Index 64import qualified Elm.Float as EF 65import qualified Elm.ModuleName as ModuleName 66import qualified Elm.String as ES 67import qualified Reporting.Annotation as A 68 69 70 71-- EXPRESSIONS 72 73 74type Expr = 75 A.Located Expr_ 76 77 78-- CACHE Annotations for type inference 79data Expr_ 80 = VarLocal Name 81 | VarTopLevel ModuleName.Canonical Name 82 | VarKernel Name Name 83 | VarForeign ModuleName.Canonical Name Annotation 84 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation 85 | VarDebug ModuleName.Canonical Name Annotation 86 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization 87 | Chr ES.String 88 | Str ES.String 89 | Int Int 90 | Float EF.Float 91 | List [Expr] 92 | Negate Expr 93 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization 94 | Lambda [Pattern] Expr 95 | Call Expr [Expr] 96 | If [(Expr, Expr)] Expr 97 | Let Def Expr 98 | LetRec [Def] Expr 99 | LetDestruct Pattern Expr Expr 100 | Case Expr [CaseBranch] 101 | Accessor Name 102 | Access Expr (A.Located Name) 103 | Update Name Expr (Map.Map Name FieldUpdate) 104 | Record (Map.Map Name Expr) 105 | Unit 106 | Tuple Expr Expr (Maybe Expr) 107 | Shader Shader.Source Shader.Types 108 109 110data CaseBranch = 111 CaseBranch Pattern Expr 112 113 114data FieldUpdate = 115 FieldUpdate A.Region Expr 116 117 118 119-- DEFS 120 121 122data Def 123 = Def (A.Located Name) [Pattern] Expr 124 | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type 125 126 127 128-- DECLARATIONS 129 130 131data Decls 132 = Declare Def Decls 133 | DeclareRec Def [Def] Decls 134 | SaveTheEnvironment 135 136 137 138-- PATTERNS 139 140 141type Pattern = 142 A.Located Pattern_ 143 144 145data Pattern_ 146 = PAnything 147 | PVar Name 148 | PRecord [Name] 149 | PAlias Pattern Name 150 | PUnit 151 | PTuple Pattern Pattern (Maybe Pattern) 152 | PList [Pattern] 153 | PCons Pattern Pattern 154 | PBool Union Bool 155 | PChr ES.String 156 | PStr ES.String 157 | PInt Int 158 | PCtor 159 { _p_home :: ModuleName.Canonical 160 , _p_type :: Name 161 , _p_union :: Union 162 , _p_name :: Name 163 , _p_index :: Index.ZeroBased 164 , _p_args :: [PatternCtorArg] 165 } 166 -- CACHE _p_home, _p_type, and _p_vars for type inference 167 -- CACHE _p_index to replace _p_name in PROD code gen 168 -- CACHE _p_opts to allocate less in PROD code gen 169 -- CACHE _p_alts and _p_numAlts for exhaustiveness checker 170 171 172data PatternCtorArg = 173 PatternCtorArg 174 { _index :: Index.ZeroBased -- CACHE for destructors/errors 175 , _type :: Type -- CACHE for type inference 176 , _arg :: Pattern 177 } 178 179 180 181-- TYPES 182 183 184data Annotation = Forall FreeVars Type 185 deriving (Eq) 186 187 188type FreeVars = Map.Map Name () 189 190 191data Type 192 = TLambda Type Type 193 | TVar Name 194 | TType ModuleName.Canonical Name [Type] 195 | TRecord (Map.Map Name FieldType) (Maybe Name) 196 | TUnit 197 | TTuple Type Type (Maybe Type) 198 | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType 199 deriving (Eq) 200 201 202data AliasType 203 = Holey Type 204 | Filled Type 205 deriving (Eq) 206 207 208data FieldType = FieldType {-# UNPACK #-} !Word16 Type 209 deriving (Eq) 210 211 212-- NOTE: The Word16 marks the source order, but it may not be available 213-- for every canonical type. For example, if the canonical type is inferred 214-- the orders will all be zeros. 215-- 216fieldsToList :: Map.Map Name FieldType -> [(Name, Type)] 217fieldsToList fields = 218 let 219 getIndex (_, FieldType index _) = 220 index 221 222 dropIndex (name, FieldType _ tipe) = 223 (name, tipe) 224 in 225 map dropIndex (List.sortOn getIndex (Map.toList fields)) 226 227 228 229-- MODULES 230 231 232data Module = 233 Module 234 { _name :: ModuleName.Canonical 235 , _exports :: Exports 236 , _docs :: Src.Docs 237 , _decls :: Decls 238 , _unions :: Map.Map Name Union 239 , _aliases :: Map.Map Name Alias 240 , _binops :: Map.Map Name Binop 241 , _effects :: Effects 242 } 243 244 245data Alias = Alias [Name] Type 246 deriving (Eq) 247 248 249data Binop = Binop_ Binop.Associativity Binop.Precedence Name 250 deriving (Eq) 251 252 253data Union = 254 Union 255 { _u_vars :: [Name] 256 , _u_alts :: [Ctor] 257 , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking 258 , _u_opts :: CtorOpts -- CACHE which optimizations are available 259 } 260 deriving (Eq) 261 262 263data CtorOpts 264 = Normal 265 | Enum 266 | Unbox 267 deriving (Eq, Ord) 268 269 270data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args 271 deriving (Eq) 272 273 274 275-- EXPORTS 276 277 278data Exports 279 = ExportEverything A.Region 280 | Export (Map.Map Name (A.Located Export)) 281 282 283data Export 284 = ExportValue 285 | ExportBinop 286 | ExportAlias 287 | ExportUnionOpen 288 | ExportUnionClosed 289 | ExportPort 290 291 292 293-- EFFECTS 294 295 296data Effects 297 = NoEffects 298 | Ports (Map.Map Name Port) 299 | Manager A.Region A.Region A.Region Manager 300 301 302data Port 303 = Incoming { _freeVars :: FreeVars, _payload :: Type, _func :: Type } 304 | Outgoing { _freeVars :: FreeVars, _payload :: Type, _func :: Type } 305 306 307data Manager 308 = Cmd Name 309 | Sub Name 310 | Fx Name Name 311 312 313 314-- BINARY 315 316 317instance Binary Alias where 318 get = liftM2 Alias get get 319 put (Alias a b) = put a >> put b 320 321 322instance Binary Union where 323 put (Union a b c d) = put a >> put b >> put c >> put d 324 get = liftM4 Union get get get get 325 326 327instance Binary Ctor where 328 get = liftM4 Ctor get get get get 329 put (Ctor a b c d) = put a >> put b >> put c >> put d 330 331 332instance Binary CtorOpts where 333 put opts = 334 case opts of 335 Normal -> putWord8 0 336 Enum -> putWord8 1 337 Unbox -> putWord8 2 338 339 get = 340 do n <- getWord8 341 case n of 342 0 -> return Normal 343 1 -> return Enum 344 2 -> return Unbox 345 _ -> fail "binary encoding of CtorOpts was corrupted" 346 347 348instance Binary Annotation where 349 get = liftM2 Forall get get 350 put (Forall a b) = put a >> put b 351 352 353instance Binary Type where 354 put tipe = 355 case tipe of 356 TLambda a b -> putWord8 0 >> put a >> put b 357 TVar a -> putWord8 1 >> put a 358 TRecord a b -> putWord8 2 >> put a >> put b 359 TUnit -> putWord8 3 360 TTuple a b c -> putWord8 4 >> put a >> put b >> put c 361 TAlias a b c d -> putWord8 5 >> put a >> put b >> put c >> put d 362 TType home name ts -> 363 let potentialWord = length ts + 7 in 364 if potentialWord <= fromIntegral (maxBound :: Word8) then 365 do putWord8 (fromIntegral potentialWord) 366 put home 367 put name 368 mapM_ put ts 369 else 370 putWord8 6 >> put home >> put name >> put ts 371 372 get = 373 do word <- getWord8 374 case word of 375 0 -> liftM2 TLambda get get 376 1 -> liftM TVar get 377 2 -> liftM2 TRecord get get 378 3 -> return TUnit 379 4 -> liftM3 TTuple get get get 380 5 -> liftM4 TAlias get get get get 381 6 -> liftM3 TType get get get 382 n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get) 383 384 385instance Binary AliasType where 386 put aliasType = 387 case aliasType of 388 Holey tipe -> putWord8 0 >> put tipe 389 Filled tipe -> putWord8 1 >> put tipe 390 391 get = 392 do n <- getWord8 393 case n of 394 0 -> liftM Holey get 395 1 -> liftM Filled get 396 _ -> fail "binary encoding of AliasType was corrupted" 397 398 399instance Binary FieldType where 400 get = liftM2 FieldType get get 401 put (FieldType a b) = put a >> put b 402