GenTypedFlatCurry.hs 19.3 KB
Newer Older
1
2
{- |
    Module      :  $Header$
3
    Description :  Generation of typed FlatCurry program terms
4
    Copyright   :  (c) 2017        Finn Teegen
5
    License     :  BSD-3-clause
6
7
8
9
10

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

11
    This module contains the generation of a typed 'FlatCurry' program term
12
13
14
    for a given module in the intermediate language.
-}
{-# LANGUAGE CPP #-}
15
module Generators.GenTypedFlatCurry (genTypedFlatCurry) where
16
17
18
19

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>), (<*>))
#endif
20
import           Control.Monad              ((<=<))
21
import           Control.Monad.Extra        (concatMapM)
22
23
import qualified Control.Monad.State as S   ( State, evalState, get, gets
                                            , modify, put )
24
25
26
import           Data.Function              (on)
import           Data.List                  (nub, sortBy)
import           Data.Maybe                 (fromMaybe)
27
import qualified Data.Map            as Map (Map, empty, insert, lookup)
28
29
30
import qualified Data.Set            as Set (Set, empty, insert, member)

import           Curry.Base.Ident
31
32
import           Curry.FlatCurry.Typed.Goodies (typeName)
import           Curry.FlatCurry.Typed.Type
33
34
35
36
37
38
39
40
41
42
43
44
45
46
import qualified Curry.Syntax as CS

import Base.CurryTypes     (toType)
import Base.Messages       (internalError)
import Base.NestEnv        ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv
                           , nestEnv, unnestEnv )
import Base.TypeExpansion
import Base.Types

import CompilerEnv
import Env.OpPrec          (mkPrec)
import Env.TypeConstructor (TCEnv)
import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValue)

47
import qualified IL
48
49
import Transformations     (transType)

50
51
-- transforms intermediate language code (IL) to typed FlatCurry code
genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
52
                  -> TProg
53
genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)
54
55
56
57
58

-- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude
-- -----------------------------------------------------------------------------

59
60
61
patchPrelude :: TProg -> TProg
patchPrelude p@(TProg n _ ts fs os)
  | n == prelude = TProg n [] ts' fs os
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
  | otherwise    = p
  where ts' = sortBy (compare `on` typeName) pts
        pts = primTypes ++ ts

primTypes :: [TypeDecl]
primTypes =
  [ Type arrow Public [0, 1] []
  , Type unit Public [] [(Cons unit 0 Public [])]
  , Type nil Public [0] [ Cons nil  0 Public []
                        , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]
                        ]
  ] ++ map mkTupleType [2 .. maxTupleArity]
  where arrow = mkPreludeQName "(->)"
        unit  = mkPreludeQName "()"
        nil   = mkPreludeQName "[]"
        cons  = mkPreludeQName ":"

mkTupleType :: Int -> TypeDecl
mkTupleType arity = Type tuple Public [0 .. arity - 1]
  [Cons tuple arity Public (map TVar [0 .. arity - 1])]
  where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"

mkPreludeQName :: String -> QName
mkPreludeQName n = (prelude, n)

prelude :: String
prelude = "Prelude"

-- |Maximal arity of tuples
maxTupleArity :: Int
maxTupleArity = 15

-- -----------------------------------------------------------------------------

-- The environment 'FlatEnv' is embedded in the monadic representation
-- 'FlatState' which allows the usage of 'do' expressions.
type FlatState a = S.State FlatEnv a

-- Data type for representing an environment which contains information needed
-- for generating FlatCurry code.
data FlatEnv = FlatEnv
  { modIdent     :: ModuleIdent      -- current module
  -- for visibility calculation
  , tyExports    :: Set.Set Ident    -- exported types
  , valExports   :: Set.Set Ident    -- exported values (functions + constructors)
  , tcEnv        :: TCEnv            -- type constructor environment
  , tyEnv        :: ValueEnv         -- type environment
  , fixities     :: [CS.IDecl]       -- fixity declarations
Finn Teegen's avatar
Finn Teegen committed
110
  , typeSynonyms :: [CS.Decl Type]   -- type synonyms
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
  , imports      :: [ModuleIdent]    -- module imports
  -- state for mapping identifiers to indexes
  , nextVar      :: Int              -- fresh variable index counter
  , varMap       :: NestEnv VarIndex -- map of identifier to variable index
  }

-- Runs a 'FlatState' action and returns the result
run :: CompilerEnv -> CS.Module Type -> FlatState a -> a
run env (CS.Module _ mid es is ds) act = S.evalState act env0
  where
  es'  = case es of Just (CS.Exporting _ e) -> e
                    _                       -> []
  env0 = FlatEnv
    { modIdent     = mid
     -- for visibility calculation
    , tyExports  = foldr (buildTypeExports  mid) Set.empty es'
    , valExports = foldr (buildValueExports mid) Set.empty es'
    -- This includes *all* imports, even unused ones
    , imports      = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]
    -- Environment to retrieve the type of identifiers
    , tyEnv        = valueEnv env
    , tcEnv        = tyConsEnv env
    -- Fixity declarations
    , fixities     = [ CS.IInfixDecl p fix (mkPrec mPrec) (qualifyWith mid o)
                     | CS.InfixDecl p fix mPrec os <- ds, o <- os
                     ]
    -- Type synonyms in the module
    , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]
    , nextVar      = 0
    , varMap       = emptyEnv
    }

-- Builds a table containing all exported identifiers from a module.
buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident
buildTypeExports mid (CS.ExportTypeWith tc _)
  | isLocalIdent mid tc = Set.insert (unqualify tc)
buildTypeExports _   _  = id

-- Builds a table containing all exported identifiers from a module.
buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident
buildValueExports mid (CS.Export             q)
  | isLocalIdent mid q  = Set.insert (unqualify q)
buildValueExports mid (CS.ExportTypeWith tc cs)
  | isLocalIdent mid tc = flip (foldr Set.insert) cs
buildValueExports _   _  = id

getModuleIdent :: FlatState ModuleIdent
getModuleIdent = S.gets modIdent

getArity :: QualIdent -> FlatState Int
getArity qid = S.gets tyEnv >>= \ env -> return $ case qualLookupValue qid env of
  [DataConstructor  _ a _ _] -> a
  [NewtypeConstructor _ _ _] -> 1
  [Value            _ _ a _] -> a
  [Label              _ _ _] -> 1
  _                          -> internalError
167
                                ("GenTypedFlatCurry.getArity: " ++ qualName qid)
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223

getFixities :: FlatState [CS.IDecl]
getFixities = S.gets fixities

-- The function 'typeSynonyms' returns the list of type synonyms.
getTypeSynonyms :: FlatState [CS.Decl Type]
getTypeSynonyms = S.gets typeSynonyms

-- Retrieve imports
getImports :: [ModuleIdent] -> FlatState [String]
getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports

-- -----------------------------------------------------------------------------
-- Stateful part, used for translation of rules and expressions
-- -----------------------------------------------------------------------------

-- resets var index and environment
withFreshEnv :: FlatState a -> FlatState a
withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act

-- Execute an action in a nested variable mapping
inNestedEnv :: FlatState a -> FlatState a
inNestedEnv act = do
  S.modify $ \ s -> s { varMap = nestEnv   $ varMap s }
  res <- act
  S.modify $ \ s -> s { varMap = unnestEnv $ varMap s }
  return res

-- Generates a new variable index for an identifier
newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)
newVar ty i = do
  idx <- (+1) <$> S.gets nextVar
  S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) }
  ty' <- trType ty
  return (idx, ty')

-- Retrieve the variable index assigned to an identifier
getVarIndex :: Ident -> FlatState VarIndex
getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of
  [v] -> return v
  _   -> internalError $ "GenFlatCurry.getVarIndex: " ++ escName i

-- -----------------------------------------------------------------------------
-- Translation of an interface
-- -----------------------------------------------------------------------------

-- Translate an operator declaration
trIOpDecl :: CS.IDecl -> FlatState [OpDecl]
trIOpDecl (CS.IInfixDecl _ fix prec op)
  = (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op
trIOpDecl _ = return []

-- -----------------------------------------------------------------------------
-- Translation of a module
-- -----------------------------------------------------------------------------

224
trModule :: IL.Module -> FlatState TProg
225
226
227
228
trModule (IL.Module mid is ds) = do
  is' <- getImports is
  sns <- getTypeSynonyms >>= concatMapM trTypeSynonym
  tds <- concatMapM trTypeDecl ds
229
  fds <- concatMapM (return . map runNormalization <=< trTFuncDecl) ds
230
  ops <- getFixities >>= concatMapM trIOpDecl
231
  return $ TProg (moduleName mid) is' (sns ++ tds) fds ops
232
233
234
235
236
237
238
239
240
241
242
243
244

-- Translate a type synonym
trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]
trTypeSynonym (CS.TypeDecl _ t tvs ty) = do
  m    <- getModuleIdent
  qid  <- flip qualifyWith t <$> getModuleIdent
  t'   <- trQualIdent qid
  vis  <- getTypeVisibility qid
  tEnv <- S.gets tcEnv
  ty'  <- trType (transType $ expandType m tEnv $ toType tvs ty)
  return [TypeSyn t' vis [0 .. length tvs - 1] ty']
trTypeSynonym _                        = return []

245
246
247
248
249
-- Translate a data declaration
-- For empty data declarations, an additional constructor is generated. This
-- is due to the fact that external data declarations are translated into data
-- declarations with zero constructors and without the additional constructor
-- empty data declarations could not be distinguished from external ones.
250
trTypeDecl :: IL.Decl -> FlatState [TypeDecl]
251
trTypeDecl (IL.DataDecl      qid a []) = do
252
  q'  <- trQualIdent qid
253
254
255
256
257
258
259
  vis <- getTypeVisibility qid
  c   <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid))
  let tvs = [0 .. a - 1]
  return [Type q' vis tvs [Cons c 1 Private [TCons q' $ map TVar tvs]]]
trTypeDecl (IL.DataDecl      qid a cs) = do
  q'  <- trQualIdent qid
  vis <- getTypeVisibility qid
260
261
  cs' <- mapM trConstrDecl cs
  return [Type q' vis [0 .. a - 1] cs']
262
263
264
265
trTypeDecl (IL.ExternalDataDecl qid a) = do
  q'  <- trQualIdent qid
  vis <- getTypeVisibility qid
  return [Type q' vis [0 .. a - 1] []]
266
trTypeDecl _                           = return []
267
268

-- Translate a constructor declaration
Finn Teegen's avatar
Finn Teegen committed
269
trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl
270
271
272
273
274
275
276
277
278
279
trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)
  <$> trQualIdent qid
  <*> getVisibility qid
  <*> mapM trType tys

-- Translate a type expression
trType :: IL.Type -> FlatState TypeExpr
trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys
trType (IL.TypeVariable      idx) = return $ TVar $ abs idx
trType (IL.TypeArrow     ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2
280
trType (IL.TypeForall    idxs ty) = ForallType (map abs idxs) <$> trType ty
281
282
283
284
285
286
287
288
289
290
291
292

-- Convert a fixity
cvFixity :: CS.Infix -> Fixity
cvFixity CS.InfixL = InfixlOp
cvFixity CS.InfixR = InfixrOp
cvFixity CS.Infix  = InfixOp

-- -----------------------------------------------------------------------------
-- Function declarations
-- -----------------------------------------------------------------------------

-- Translate a function declaration
293
294
trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]
trTFuncDecl (IL.FunctionDecl f vs _ e) = do
295
296
297
298
  f'  <- trQualIdent f
  a   <- getArity f
  vis <- getVisibility f
  ty' <- trType ty
299
300
  r'  <- trTRule vs e
  return [TFunc f' a vis ty' r']
301
  where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs
302
trTFuncDecl (IL.ExternalDecl     f ty) = do
303
304
305
306
  f'   <- trQualIdent f
  a    <- getArity f
  vis  <- getVisibility f
  ty'  <- trType ty
307
308
309
  r'   <- trTExternal ty f
  return [TFunc f' a vis ty' r']
trTFuncDecl _                           = return []
310
311
312

-- Translate a function rule.
-- Resets variable index so that for every rule variables start with index 1
313
314
315
316
trTRule :: [(IL.Type, Ident)] -> IL.Expression
        -> FlatState TRule
trTRule vs e = withFreshEnv $ TRule <$> mapM (uncurry newVar) vs
                                    <*> trTExpr e
317

318
319
trTExternal :: IL.Type -> QualIdent -> FlatState TRule
trTExternal ty f = flip TExternal (qualName f) <$> trType ty
320
321

-- Translate an expression
322
323
324
325
326
327
328
trTExpr :: IL.Expression -> FlatState TExpr
trTExpr (IL.Literal       ty l) = TLit  <$> trType ty <*> trLiteral l
trTExpr (IL.Variable      ty v) = TVarE <$> trType ty <*> getVarIndex v
trTExpr (IL.Function    ty f _) = genCall Fun ty f []
trTExpr (IL.Constructor ty c _) = genCall Con ty c []
trTExpr (IL.Apply        e1 e2) = trApply e1 e2
trTExpr (IL.Case        t e bs) = TCase (cvEval t) <$> trTExpr e
329
                                  <*> mapM (inNestedEnv . trAlt) bs
330
331
trTExpr (IL.Or           e1 e2) = TOr <$> trTExpr e1 <*> trTExpr e2
trTExpr (IL.Exist       v ty e) = inNestedEnv $ do
332
  v' <- newVar ty v
333
334
335
336
  e' <- trTExpr e
  return $ case e' of TFree vs e'' -> TFree (v' : vs) e''
                      _            -> TFree (v' : []) e'
trTExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do
337
  v' <- newVar (IL.typeOf b) v
338
339
340
341
342
  b' <- trTExpr b
  e' <- trTExpr e
  return $ case e' of TLet bs e'' -> TLet ((v', b'):bs) e''
                      _           -> TLet ((v', b'):[]) e'
trTExpr (IL.Letrec   bs e) = inNestedEnv $ do
343
  let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]
344
345
346
  TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es)
       <*> trTExpr e
trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty'
347
  where ty' = trType $ IL.typeOf e
348
349
350
351
352
353
354
355

-- Translate a literal
trLiteral :: IL.Literal -> FlatState Literal
trLiteral (IL.Char  c) = return $ Charc  c
trLiteral (IL.Int   i) = return $ Intc   i
trLiteral (IL.Float f) = return $ Floatc f

-- Translate a higher-order application
356
trApply :: IL.Expression -> IL.Expression -> FlatState TExpr
357
358
359
360
361
362
363
trApply e1 e2 = genFlatApplic e1 [e2]
  where
  genFlatApplic e es = case e of
    IL.Apply        ea eb -> genFlatApplic ea (eb:es)
    IL.Function    ty f _ -> genCall Fun ty f es
    IL.Constructor ty c _ -> genCall Con ty c es
    _ -> do
364
      expr <- trTExpr e
365
366
367
      genApply expr es

-- Translate an alternative
368
369
trAlt :: IL.Alt -> FlatState TBranchExpr
trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e
370
371

-- Translate a pattern
372
373
trPat :: IL.ConstrTerm -> FlatState TPattern
trPat (IL.LiteralPattern        ty l) = TLPattern <$> trType ty <*> trLiteral l
374
375
trPat (IL.ConstructorPattern ty c vs) =
  TPattern <$> trType ty <*> trQualIdent c <*> mapM (uncurry newVar) vs
376
trPat (IL.VariablePattern        _ _) = internalError "GenTypedFlatCurry.trPat"
377
378
379
380
381
382
383
384
385
386

-- Convert a case type
cvEval :: IL.Eval -> CaseType
cvEval IL.Rigid = Rigid
cvEval IL.Flex  = Flex

data Call = Fun | Con

-- Generate a function or constructor call
genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]
387
        -> FlatState TExpr
388
389
390
391
genCall call ty f es = do
  f'    <- trQualIdent f
  arity <- getArity f
  case compare supplied arity of
392
393
    LT -> genTComb ty f' es (part call (arity - supplied))
    EQ -> genTComb ty f' es (full call)
394
395
    GT -> do
      let (es1, es2) = splitAt arity es
396
      funccall <- genTComb ty f' es1 (full call)
397
398
399
400
401
402
403
404
      genApply funccall es2
  where
  supplied = length es
  full Fun = FuncCall
  full Con = ConsCall
  part Fun = FuncPartCall
  part Con = ConsPartCall

405
406
genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr
genTComb ty qid es ct = do
407
  ty' <- trType ty
408
409
410
411
412
413
  let ty'' = defunc ty' (length es)
  TComb ty'' ct qid <$> mapM trTExpr es
  where
  defunc t               0 = t
  defunc (FuncType _ t2) n = defunc t2 (n - 1)
  defunc _               _ = internalError "GenTypedFlatCurry.genTComb.defunc"
414

415
genApply :: TExpr -> [IL.Expression] -> FlatState TExpr
416
genApply e es = do
417
  ap  <- trQualIdent qApplyId
418
  es' <- mapM trTExpr es
419
420
  return $ foldl (\e1 e2 -> let FuncType _ ty2 = typeOf e1
                            in TComb ty2 FuncCall ap [e1, e2])
421
             e es'
422

423
424
425
426
427
428
429
430
431
432
433
434
-- -----------------------------------------------------------------------------
-- Normalization
-- -----------------------------------------------------------------------------

runNormalization :: Normalize a => a -> a
runNormalization x = S.evalState (normalize x) (0, Map.empty)

type NormState a = S.State (Int, Map.Map Int Int) a

class Normalize a where
  normalize :: a -> NormState a

435
436
instance Normalize Int where
  normalize i = do
437
438
439
440
    (n, m) <- S.get
    case Map.lookup i m of
      Nothing -> do
        S.put (n + 1, Map.insert i n m)
441
442
443
444
445
446
447
448
449
        return n
      Just n' -> return n'

instance Normalize TypeExpr where
  normalize (TVar           i) = TVar <$> normalize i
  normalize (TCons      q tys) = TCons q <$> mapM normalize tys
  normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2
  normalize (ForallType is ty) =
    ForallType <$> mapM normalize is <*> normalize ty
450
451

instance Normalize b => Normalize (a, b) where
452
  normalize (x, y) = (,) x <$> normalize y
453

454
455
instance Normalize TFuncDecl where
  normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r
456

457
458
instance Normalize TRule where
  normalize (TRule        vs e) = TRule <$> mapM normalize vs
459
                                        <*> normalize e
460
461
462
  normalize (TExternal ty    s) = flip TExternal s <$> normalize ty

instance Normalize TExpr where
463
  normalize (TVarE  ty       v) = flip TVarE  v <$> normalize ty
464
  normalize (TLit   ty       l) = flip TLit  l  <$> normalize ty
465
466
  normalize (TComb  ty ct f es) = flip TComb ct <$> normalize ty
                                                <*> pure f
467
468
                                                <*> mapM normalize es
  normalize (TLet        ds e) = TLet <$> mapM normalizeBinding ds
469
470
                                      <*> normalize e
    where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b
471
  normalize (TOr          a b) = TOr <$> normalize a
472
                                     <*> normalize b
473
474
475
  normalize (TCase    ct e bs) = TCase ct <$> normalize e
                                          <*> mapM normalize bs
  normalize (TFree       vs e) = TFree <$> mapM normalize vs
476
                                       <*> normalize e
477
  normalize (TTyped     e ty') = TTyped <$> normalize e
478
479
                                        <*> normalize ty'

480
481
instance Normalize TBranchExpr where
  normalize (TBranch p e) = TBranch <$> normalize p <*> normalize e
482

483
instance Normalize TPattern where
484
485
  normalize (TPattern  ty c vs) = TPattern <$> normalize ty
                                           <*> pure c
486
                                           <*> mapM normalize vs
487
  normalize (TLPattern ty    l) = flip TLPattern l <$> normalize ty
488
489

-- -----------------------------------------------------------------------------
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
-- Helper functions
-- -----------------------------------------------------------------------------

trQualIdent :: QualIdent -> FlatState QName
trQualIdent qid = do
  mid <- getModuleIdent
  return $ (moduleName $ fromMaybe mid mid', idName i)
  where
  mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i
       = Just preludeMIdent
       | otherwise
       = qidModule qid
  i = qidIdent qid

getTypeVisibility :: QualIdent -> FlatState Visibility
getTypeVisibility i = S.gets $ \s ->
  if Set.member (unqualify i) (tyExports s) then Public else Private

getVisibility :: QualIdent -> FlatState Visibility
getVisibility i = S.gets $ \s ->
  if Set.member (unqualify i) (valExports s) then Public else Private