compiler/ndpFlatten/Flattening.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 --  $Id$
   9 --
  10 --  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
  11 --
  12 --  Vectorisation and lifting
  13 --
  14 --- DESCRIPTION ---------------------------------------------------------------
  15 --
  16 --  This module implements the vectorisation and function lifting
  17 --  transformations of the flattening transformation.
  18 --
  19 --- DOCU ----------------------------------------------------------------------
  20 --
  21 --  Language: Haskell 98 with C preprocessor
  22 --
  23 --  Types:
  24 --    the transformation on types has five purposes:
  25 --
  26 --        1) for each type definition, derive the lifted version of this type
  27 --             liftTypeef
  28 --        2) change the type annotations of functions & variables acc. to rep.
  29 --             flattenType
  30 --        3) derive the type of a lifted function
  31 --             liftType
  32 --        4) sumtypes:
  33 --             this is the most fuzzy and complicated part. For each lifted
  34 --             sumtype we need to generate function to access and combine the
  35 --             component arrays
  36 --
  37 --   NOTE: the type information of variables and data constructors is *not*
  38 --          changed to reflect it's representation. This has to be solved
  39 --          somehow (???, FIXME)  using type indexed types
  40 --
  41 --   Vectorisation:
  42 --    is very naive at the moment. One of the most striking inefficiencies is
  43 --    application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a
  44 --    lambda abstraction. The vectorisation produces a pair consisting of the
  45 --    original and the lifted function, but the lifted version is discarded.
  46 --    I'm also not sure how much of this would be thrown out by the simplifier
  47 --    eventually
  48 --
  49 --        *) vectorise
  50 --
  51 --  Conventions:
  52 --
  53 --- TODO ----------------------------------------------------------------------
  54 --
  55 --   * look closer into the definition of type definition (TypeThing or so)
  56 --
  57
  58 module Flattening (
  59   flatten, flattenExpr,
  60 ) where
  61
  62 #include "HsVersions.h"
  63
  64 -- friends
  65 import NDPCoreUtils (tupleTyArgs, funTyArgs, isDefault,
  66                      isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
  67 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
  68                      liftVar, liftConst, intersectWithContext, mk'fst,
  69                      mk'mapP, mk'bpermuteDftP, mk'indexOfP,mk'eq,mk'neq)
  70
  71 -- GHC
  72 import TcType       ( tcIsForAllTy, tcView )
  73 import TypeRep      ( Type(..) )
  74 import Coercion     ( coercionKind )
  75 import StaticFlags  (opt_Flatten)
  76 import Panic        (panic)
  77 import ErrUtils     (dumpIfSet_dyn)
  78 import UniqSupply   (mkSplitUniqSupply)
  79 import DynFlags  (DynFlag(..))
  80 import Literal      (Literal, literalType)
  81 import Var          (Var(..), idType, isTyVar)
  82 import Id           (setIdType)
  83 import DataCon      (DataCon, dataConTag)
  84 import HscTypes     ( ModGuts(..), HscEnv(..), hscEPS )
  85 import CoreFVs      (exprFreeVars)
  86 import CoreSyn      (Expr(..), Bind(..), Alt, AltCon(..),
  87                      CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
  88                      mkApps, mkIntLitInt)
  89 import PprCore      (pprCoreExpr)
  90 import CoreLint     (showPass, endPass)
  91
  92 import CoreUtils    (exprType, applyTypeToArg, mkPiType)
  93 import VarEnv       (zipVarEnv)
  94 import TysWiredIn   (mkTupleTy)
  95 import BasicTypes   (Boxity(..))
  96 import Outputable
  97 import FastString
  98
  99 -- standard
 100 import Monad        (liftM, foldM)
 101
 102 -- toplevel transformation
 103 -- -----------------------
 104
 105 -- entry point to the flattening transformation for the compiler driver when
 106 -- compiling a complete module (EXPORTED)
 107 --
 108 flatten :: HscEnv
 109         -> ModGuts
 110         -> IO ModGuts
 111 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
 112   | not opt_Flatten = return mod_impl -- skip without -fflatten
 113   | otherwise       =
 114   do
 115     let dflags = hsc_dflags hsc_env
 116
 117     eps <- hscEPS hsc_env
 118     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 119     --
 120     -- announce vectorisation
 121     --
 122     showPass dflags "Flattening [first phase: vectorisation]"
 123     --
 124     -- vectorise all toplevel bindings
 125     --
 126     let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
 127     --
 128     -- and dump the result if requested
 129     --
 130     endPass dflags "Flattening [first phase: vectorisation]"
 131             Opt_D_dump_vect binds'
 132     return $ mod_impl {mg_binds = binds'}
 133
 134 -- entry point to the flattening transformation for the compiler driver when
 135 -- compiling a single expression in interactive mode (EXPORTED)
 136 --
 137 flattenExpr :: HscEnv
 138             -> CoreExpr                 -- the expression to be flattened
 139             -> IO CoreExpr
 140 flattenExpr hsc_env expr
 141   | not opt_Flatten = return expr       -- skip without -fflatten
 142   | otherwise       =
 143   do
 144     let dflags = hsc_dflags hsc_env
 145     eps <- hscEPS hsc_env
 146
 147     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 148     --
 149     -- announce vectorisation
 150     --
 151     showPass dflags "Flattening [first phase: vectorisation]"
 152     --
 153     -- vectorise the expression
 154     --
 155     let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
 156     --
 157     -- and dump the result if requested
 158     --
 159     dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
 160                   (pprCoreExpr expr')
 161     return expr'
 162
 163
 164 -- vectorisation of bindings and expressions
 165 -- -----------------------------------------
 166
 167
 168 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
 169 vectoriseTopLevelBinds binds =
 170   do
 171     vbinds <- mapM vectoriseBind binds
 172     return (adjustTypeBinds vbinds)
 173
 174 adjustTypeBinds:: [CoreBind] -> [CoreBind]
 175 adjustTypeBinds vbinds =
 176     let
 177        ids = concat (map extIds vbinds)
 178        idEnv =  zipVarEnv ids ids
 179      in map (substIdEnvBind idEnv) vbinds
 180   where
 181     -- FIXME replace by 'bindersOf'
 182     extIds (NonRec b expr) = [b]
 183     extIds (Rec      bnds) = map fst bnds
 184     substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
 185     substIdEnvBind idEnv (Rec bnds)
 186        = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
 187
 188 -- vectorise a single core binder
 189 --
 190 vectoriseBind                 :: CoreBind -> Flatten CoreBind
 191 vectoriseBind (NonRec b expr)  =
 192   liftM (NonRec b) $ liftM fst $ vectorise expr
 193 vectoriseBind (Rec bindings)   =
 194   liftM Rec        $ mapM vectoriseOne bindings
 195   where
 196     vectoriseOne (b, expr) =
 197       do
 198         (vexpr, ty) <- vectorise expr
 199         return (setIdType b ty, vexpr)
 200
 201
 202 -- Searches for function definitions and creates a lifted version for
 203 -- each function.
 204 -- We have only two interesting cases:
 205 -- 1) function application  (ex1) (ex2)
 206 --      vectorise both subexpressions. The function will end up becoming a
 207 --      pair (orig. fun, lifted fun), choose first component (in many cases,
 208 --      this is pretty inefficient, since the lifted version is generated
 209 --      although it is clear that it won't be used
 210 --
 211 -- 2) lambda abstraction
 212 --      any function has to exist in two forms: it's original form and it's
 213 --      lifted form. Therefore, every lambda abstraction is transformed into
 214 --      a pair of functions: the original function and its lifted variant
 215 --
 216 --
 217 --  FIXME: currently, I use 'exprType' all over the place - this is terribly
 218 --  inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
 219 --  return the type of the result expression as well.
 220 --
 221 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
 222 vectorise (Var id)  =
 223   do
 224     let varTy  = idType id
 225     let vecTy  = vectoriseTy varTy
 226     return (Var (setIdType id vecTy), vecTy)
 227
 228 vectorise (Lit lit) =
 229   return ((Lit lit), literalType lit)
 230
 231
 232 vectorise e@(App expr t@(Type _)) =
 233   do
 234     (vexpr, vexprTy) <- vectorise expr
 235     return ((App vexpr t), applyTypeToArg vexprTy t)
 236
 237 vectorise  (App (Lam b expr) arg) =
 238   do
 239     (varg, argTy)    <- vectorise arg
 240     (vexpr, vexprTy) <- vectorise expr
 241     let vb            = setIdType b argTy
 242     return ((App (Lam vb  vexpr) varg),
 243             applyTypeToArg (mkPiType vb vexprTy) varg)
 244
 245 -- if vexpr expects a type as first argument
 246 -- application stays just as it is
 247 --
 248 vectorise (App expr arg) =
 249   do
 250     (vexpr, vexprTy) <-  vectorise expr
 251     (varg,  vargTy)  <-  vectorise arg
 252
 253     if (tcIsForAllTy vexprTy)
 254       then do
 255         let resTy =  applyTypeToArg vexprTy varg
 256         return (App vexpr varg, resTy)
 257       else do
 258         let [t1, t2] = tupleTyArgs  vexprTy
 259         vexpr'      <-  mk'fst t1 t2 vexpr
 260         let resTy    = applyTypeToArg t1 varg
 261         return  ((App vexpr' varg), resTy)  -- apply the first component of
 262                                             -- the vectorized function
 263
 264 vectorise  e@(Lam b expr)
 265   | isTyVar b
 266   =  do
 267         (vexpr, vexprTy) <- vectorise expr          -- don't vectorise 'b'!
 268         return ((Lam b vexpr), mkPiType b vexprTy)
 269   | otherwise =
 270      do
 271        (vexpr, vexprTy)  <- vectorise expr
 272        let vb             = setIdType b (vectoriseTy (idType b))
 273        let ve             =  Lam  vb  vexpr
 274        (lexpr, lexprTy)  <- lift e
 275        let veTy = mkPiType vb vexprTy
 276        return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
 277                  mkTupleTy Boxed 2 [veTy, lexprTy])
 278
 279 vectorise (Let bind body) =
 280   do
 281     vbind            <- vectoriseBind bind
 282     (vbody, vbodyTy) <- vectorise body
 283     return ((Let vbind vbody), vbodyTy)
 284
 285 vectorise (Case expr b ty alts) =
 286   do
 287     (vexpr, vexprTy) <- vectorise expr
 288     valts <- mapM vectorise' alts
 289     let res_ty = snd (head valts)
 290     return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
 291   where vectorise' (con, bs, expr) =
 292           do
 293             (vexpr, vexprTy) <- vectorise expr
 294             return ((con, bs, vexpr), vexprTy)  -- FIXME: change type of con
 295                                                 --   and bs
 296
 297
 298
 299 vectorise (Note note expr) =
 300  do
 301    (vexpr, vexprTy) <- vectorise expr        -- FIXME: is this ok or does it
 302    return ((Note note vexpr), vexprTy)       --   change the validity of note?
 303
 304 vectorise e@(Type t) =
 305   return (e, t)                              -- FIXME: panic instead of 't'???
 306
 307
 308 {-
 309 myShowTy (TyVarTy _) = "TyVar "
 310 myShowTy (AppTy t1 t2) =
 311   "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
 312 myShowTy (TyConApp _ t) =
 313   "TyConApp TC (" ++ (myShowTy t) ++ ")"
 314 -}
 315
 316 vectoriseTy :: Type -> Type
 317 vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
 318         -- Look through notes and synonyms
 319         -- NB: This will discard notes and synonyms, of course
 320         -- ToDo: retain somehow?
 321 vectoriseTy t@(TyVarTy v)      =  t
 322 vectoriseTy t@(AppTy t1 t2)    =
 323   AppTy (vectoriseTy t1) (vectoriseTy t2)
 324 vectoriseTy t@(TyConApp tc ts) =
 325   TyConApp tc (map vectoriseTy ts)
 326 vectoriseTy t@(FunTy t1 t2)    =
 327   mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
 328                      (liftTy t)]
 329 vectoriseTy  t@(ForAllTy v ty)  =
 330   ForAllTy v (vectoriseTy  ty)
 331 vectoriseTy  t =  t
 332
 333
 334 -- liftTy: wrap the type in an array but be careful with function types
 335 --    on the *top level* (is this sufficient???)
 336
 337 liftTy:: Type -> Type
 338 liftTy ty | Just ty' <- tcView ty = liftTy ty'
 339 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 340 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
 341 liftTy  t              = mkPArrTy t
 342
 343
 344 --  lifting:
 345 -- ----------
 346 --  * liftType
 347 --  * lift
 348
 349
 350 -- liftBinderType: Converts a  type 'a' stored in the binder to the
 351 -- representation of '[:a:]' will therefore call liftType
 352 --
 353 --  lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
 354 --  but I'm not entirely sure about some fields (e.g., strictness info)
 355 liftBinderType:: CoreBndr ->  Flatten CoreBndr
 356 liftBinderType bndr = return $  setIdType bndr (liftTy (idType bndr))
 357
 358 -- lift: lifts an expression (a -> [:a:])
 359 -- If the expression is a simple expression, it is treated like a constant
 360 -- expression.
 361 -- If the body of a lambda expression is a simple expression, it is
 362 -- transformed into a mapP
 363 lift:: CoreExpr -> Flatten (CoreExpr, Type)
 364 lift cExpr@(Var id)    =
 365   do
 366     lVar@(Var lId) <- liftVar id
 367     return (lVar, idType lId)
 368
 369 lift cExpr@(Lit lit)   =
 370   do
 371     lLit  <- liftConst cExpr
 372     return (lLit, exprType lLit)
 373
 374
 375 lift (Lam b expr)
 376   | isSimpleExpr expr      =  liftSimpleFun b expr
 377   | isTyVar b =
 378     do
 379       (lexpr, lexprTy) <- lift expr  -- don't lift b!
 380       return (Lam b lexpr, mkPiType b lexprTy)
 381   | otherwise =
 382     do
 383       lb               <- liftBinderType b
 384       (lexpr, lexprTy) <- extendContext [lb] (lift expr)
 385       return ((Lam lb lexpr) , mkPiType lb lexprTy)
 386
 387 lift (App expr1 expr2) =
 388   do
 389     (lexpr1, lexpr1Ty) <- lift expr1
 390     (lexpr2, _)        <- lift expr2
 391     return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
 392
 393
 394 lift (Let (NonRec b expr1) expr2)
 395   |isSimpleExpr expr2 =
 396     do
 397       (lexpr1, _)        <- lift expr1
 398       (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
 399       let (t1, t2) = funTyArgs lexpr2Ty
 400       liftM (\x -> (x, liftTy t2)) $  mk'mapP t1 t2 lexpr2 lexpr1
 401
 402   | otherwise =
 403     do
 404       (lexpr1, _)        <- lift expr1
 405       lb                 <- liftBinderType b
 406       (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
 407       return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
 408
 409 lift (Let (Rec binds) expr2) =
 410   do
 411     let (bndVars, exprs)  = unzip binds
 412     lBndVars           <- mapM liftBinderType bndVars
 413     lexprs             <- extendContext bndVars (mapM lift exprs)
 414     (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
 415     return ((Let (Rec (zip  lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
 416
 417 -- FIXME:
 418 -- Assumption: alternatives can either be literals or data construtors.
 419 --             Due to type restrictions, I don't think it is possible
 420 --             that they are mixed.
 421 --             The handling of literals and data constructors is completely
 422 --             different
 423 --
 424 --
 425 -- let b = expr in alts
 426 --
 427 -- I think I read somewhere that the default case (if present) is stored
 428 -- in the head of the list. Assume for now this is true, have to check
 429 --
 430 -- (1) literals
 431 -- (2) data constructors
 432 --
 433 -- FIXME: optimisation: first, filter out all simple expression and
 434 --   loop (mapP & filter) over all the corresponding values in a single
 435 --   traversal:
 436
 437 --    (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
 438 --                                       simple alts     reg alts
 439 --    (2) if simpleAlts = [] then (just as before)
 440 --        if regAlts    = [] then (the whole thing is just a loop)
 441 --        otherwise (a) compute index vector for simpleAlts (for def permute
 442 --                      later on
 443 --                  (b)
 444 -- gaw 2004 FIX?
 445 lift cExpr@(Case expr b _ alts)  =
 446   do
 447     (lExpr, _) <- lift expr
 448     lb    <- liftBinderType  b     -- lift alt-expression
 449     lalts <- if isLit alts
 450                 then extendContext [lb] (liftCaseLit b alts)
 451                 else extendContext [lb] (liftCaseDataCon b alts)
 452     letWrapper lExpr b lalts
 453
 454 lift (Cast expr co) =
 455   do
 456     (lexpr, t) <- lift expr
 457     let lco = liftTy co
 458     let (t1, t2) = coercionKind lco
 459     return ((Cast expr lco), t2)
 460
 461 lift (Note note expr) =
 462   do
 463     (lexpr, t) <- lift expr
 464     return ((Note note lexpr), t)
 465
 466 lift e@(Type t) = return (e, t)
 467
 468
 469 -- auxilliary functions for lifting of case statements
 470 --
 471
 472 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
 473        Flatten (([CoreBind], [CoreBind], [CoreBind]))
 474 liftCaseDataCon b [] =
 475   return ([], [], [])
 476 liftCaseDataCon b alls@(alt:alts)
 477   | isDefault alt  =
 478     do
 479       (i,  e,  defAltBndrs) <- liftCaseDataConDefault b alt alts
 480       (is, es, altBndrs)    <- liftCaseDataCon' b alts
 481       return (i:is, e:es, defAltBndrs ++ altBndrs)
 482   | otherwise =
 483     liftCaseDataCon' b alls
 484
 485 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
 486     Flatten ([CoreBind], [CoreBind], [CoreBind])
 487 liftCaseDataCon' _ [] =
 488   do
 489     return ([], [], [])
 490
 491
 492 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
 493   do
 494     (permBnd, exprBnd, packBnd)    <-  liftSingleDataCon b dcon bnds expr
 495     (permBnds, exprBnds, packBnds) <-  liftCaseDataCon' b alts
 496     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 497
 498
 499 -- FIXME: is is really necessary to return the binding to the permutation
 500 -- array in the data constructor case, as the representation already
 501 -- contains the extended flag vector
 502 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
 503   Flatten (CoreBind, CoreBind, [CoreBind])
 504 liftSingleDataCon b dcon bnds expr =
 505   do
 506     let dconId           = dataConTag dcon
 507     indexExpr           <- mkIndexOfExprDCon (idType b)  b dconId
 508     (bb, bbind)         <- mkBind FSLIT("is") indexExpr
 509     lbnds               <- mapM liftBinderType bnds
 510     ((lExpr, _), bnds') <- packContext  bb (extendContext lbnds (lift expr))
 511     (_, vbind)          <- mkBind FSLIT("r") lExpr
 512     return (bbind, vbind, bnds')
 513
 514 -- FIXME: clean this up. the datacon and the literal case are so
 515 --   similar that it would be easy to use the same function here
 516 --   instead of duplicating all the code.
 517 --
 518 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 519   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 520 liftCaseDataConDefault b (_, _, def) alts =
 521   do
 522     let dconIds        = map (\(DataAlt d, _, _) -> dataConTag d) alts
 523     indexExpr         <- mkIndexOfExprDConDft (idType b) b dconIds
 524     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 525     ((lDef, _), bnds) <- packContext  bb (lift def)
 526     (_, vbind)        <- mkBind FSLIT("r") lDef
 527     return (bbind, vbind, bnds)
 528
 529 -- liftCaseLit: checks if we have a default case and handles it
 530 -- if necessary
 531 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
 532        Flatten ([CoreBind], [CoreBind], [CoreBind])
 533 liftCaseLit b [] =
 534     return ([], [], [])    --FIXME: a case with no cases at all???
 535 liftCaseLit b alls@(alt:alts)
 536   | isDefault alt  =
 537     do
 538         (i,  e,  defAltBndrs) <- liftCaseLitDefault b alt alts
 539         (is, es, altBndrs)    <- liftCaseLit' b alts
 540         return (i:is, e:es, defAltBndrs ++ altBndrs)
 541   | otherwise =
 542     do
 543       liftCaseLit' b alls
 544
 545 -- liftCaseLitDefault: looks at all the other alternatives which
 546 --    contain a literal and filters all those elements from the
 547 --    array which do not match any of the literals in the other
 548 --    alternatives.
 549 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 550   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 551 liftCaseLitDefault b (_, _, def) alts =
 552   do
 553     let lits           = map (\(LitAlt l, _, _) -> l) alts
 554     indexExpr         <- mkIndexOfExprDft (idType b) b lits
 555     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 556     ((lDef, _), bnds) <- packContext  bb (lift def)
 557     (_, vbind)        <- mkBind FSLIT("r") lDef
 558     return (bbind, vbind, bnds)
 559
 560 -- FIXME:
 561 --  Assumption: in case of Lit, the list of binders of the alt is empty.
 562 --
 563 -- returns
 564 --   a list of all vars bound to the expr in the body of the alternative
 565 --   a list of (var, expr) pairs, where var has to be bound to expr
 566 --   by letWrapper
 567 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
 568     Flatten ([CoreBind], [CoreBind], [CoreBind])
 569 liftCaseLit' _ [] =
 570   do
 571     return ([], [], [])
 572 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
 573   do
 574     (permBnd, exprBnd, packBnd)    <-  liftSingleCaseLit b lit expr
 575     (permBnds, exprBnds, packBnds) <-  liftCaseLit' b alts
 576     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 577
 578 -- lift a single alternative of the form: case  b of lit -> expr.
 579 --
 580 --   It returns the bindings:
 581 --   (a) let b' = indexOfP (mapP (\x -> x == lit) b)
 582 --
 583 --   (b) lift expr in the packed context. Returns lexpr and the
 584 --       list of binds (bnds) that describe the packed arrays
 585 --
 586 --   (c) create new var v' to bind lexpr to
 587 --
 588 --   (d) return (b' = indexOf...., v' = lexpr, bnds)
 589 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr  ->
 590   Flatten (CoreBind, CoreBind, [CoreBind])
 591 liftSingleCaseLit b lit expr =
 592  do
 593    indexExpr          <- mkIndexOfExpr (idType b) b lit -- (a)
 594    (bb, bbind)        <- mkBind FSLIT("is") indexExpr
 595    ((lExpr, t), bnds) <- packContext  bb (lift expr)     -- (b)
 596    (_, vbind)         <- mkBind FSLIT("r") lExpr
 597    return (bbind, vbind, bnds)
 598
 599 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
 600 --
 601 -- let b = lExpr in
 602 --  let index_bnd_1 in
 603 --    let packbnd_11 in
 604 --      ... packbnd_1m in
 605 --         let exprbnd_1 in        ....
 606 --      ...
 607 --          let nvar = replicate dummy (length <current context>)
 608 --               nvar1 = bpermuteDftP index_bnd_1 ...
 609 --
 610 --   in bpermuteDftP index_bnd_n nvar_(n-1)
 611 --
 612 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
 613   Flatten (CoreExpr, Type)
 614 letWrapper lExpr b (indBnds, exprBnds, pckBnds)  =
 615   do
 616     (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
 617     let resExpr      = getExprOfBind (head defBpBnds)
 618     return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
 619
 620 -- dftbpBinders: return the list of binders necessary to construct the overall
 621 --   result from the subresults computed in the different branches of the case
 622 --   statement. The binding which contains the final result is in the *head*
 623 --   of the result list.
 624 --
 625 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
 626 --
 627 -- let def = replicate (length of context) undefined
 628 --     d1  = bpermuteDftP dft e1 i1
 629 --     .....
 630 --
 631 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
 632 dftbpBinders indexBnds exprBnds =
 633   do
 634     let expr = getExprOfBind (head exprBnds)
 635     defVecExpr     <- createDftArrayBind expr
 636     ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
 637     return ((b:bnds),t)
 638   where
 639     dftbpBinders' :: [CoreBind]
 640                   -> [CoreBind]
 641                   -> CoreBind
 642                   -> Flatten ((CoreBind, [CoreBind]), Type)
 643     dftbpBinders' [] [] cBnd =
 644       return ((cBnd, []), panic "dftbpBinders: undefined type")
 645     dftbpBinders' (i:is) (e:es) cBind =
 646       do
 647         let iVar = getVarOfBind i
 648         let eVar = getVarOfBind e
 649         let cVar = getVarOfBind cBind
 650         let ty   = idType eVar
 651         newBnd  <- mkDftBackpermute ty iVar eVar cVar
 652         ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
 653         return ((fBnd, (newBnd:restBnds)), liftTy ty)
 654
 655     dftbpBinders'  _ _ _ =
 656       panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
 657
 658 getExprOfBind:: CoreBind -> CoreExpr
 659 getExprOfBind (NonRec _ expr) = expr
 660
 661 getVarOfBind:: CoreBind -> Var
 662 getVarOfBind (NonRec b _) = b
 663
 664
 665
 666 -- Optimised Transformation
 667 -- =========================
 668 --
 669
 670 -- liftSimpleFun
 671 --   if variables x_1 to x_i occur in the context *and* free in expr
 672 --   then
 673 --   (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
 674 --
 675 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
 676 liftSimpleFun b expr =
 677   do
 678     bndVars <- collectBoundVars expr
 679     let bndVars'     = b:bndVars
 680         bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
 681         lamExpr      = mkLams (b:bndVars) expr     -- FIXME: should be tuple
 682                                                    -- here
 683     let (t1, t2)     = funTyArgs . exprType $ lamExpr
 684     mapExpr         <-  mk'mapP t1 t2 lamExpr bndVarsTuple
 685     let lexpr        = mkApps mapExpr [bndVarsTuple]
 686     return (lexpr, undefined)                      -- FIXME!!!!!
 687
 688
 689 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
 690 collectBoundVars  expr =
 691   intersectWithContext (exprFreeVars expr)
 692
 693
 694 -- auxilliary routines
 695 -- -------------------
 696
 697 -- mkIndexOfExpr b lit ->
 698 --   indexOf (mapP (\x -> x == lit) b) b
 699 --
 700 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
 701 mkIndexOfExpr  idType b lit =
 702   do
 703     eqExpr        <- mk'eq idType (Var b) (Lit lit)
 704     let lambdaExpr = (Lam b eqExpr)
 705     mk'indexOfP idType  lambdaExpr (Var b)
 706
 707 -- there is FlattenMonad.mk'indexOfP as well as
 708 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 709
 710 -- for case-distinction over data constructors:
 711 -- let b = expr in
 712 --   case b of
 713 --      dcon args -> ....
 714 -- dconId = dataConTag dcon
 715 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
 716 -- indexOfP (\x -> x == dconId) b)
 717 --
 718 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
 719 mkIndexOfExprDCon  idType b dId =
 720   do
 721     let intExpr    = mkIntLitInt dId
 722     eqExpr        <- mk'eq  idType (Var b) intExpr
 723     let lambdaExpr = (Lam b intExpr)
 724     mk'indexOfP idType lambdaExpr (Var b)
 725
 726
 727
 728 -- there is FlattenMonad.mk'indexOfP as well as
 729 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 730
 731 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
 732 -- default case. "dconIds" is a list of all the data constructor idents which
 733 -- are covered by the other cases.
 734 -- indexOfP (\x -> x != dconId_1 && ....) b)
 735 --
 736 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
 737 mkIndexOfExprDConDft idType b dId  =
 738   do
 739     let intExprs   = map mkIntLitInt dId
 740     bExpr         <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
 741     let lambdaExpr = (Lam b bExpr)
 742     mk'indexOfP idType (Var b) bExpr
 743
 744
 745 -- mkIndexOfExprDef b [lit1, lit2,...] ->
 746 --   indexOf (\x -> not (x == lit1 || x == lit2 ....) b
 747 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
 748 mkIndexOfExprDft idType b lits =
 749   do
 750     let litExprs   = map (\l-> Lit l)  lits
 751     bExpr         <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
 752     let lambdaExpr = (Lam b bExpr)
 753     mk'indexOfP idType bExpr (Var b)
 754
 755
 756 -- create a back-permute binder
 757 --
 758 --  * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
 759 --   Core binding of the form
 760 --
 761 --     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
 762 --
 763 --   where `x' is a new local variable
 764 --
 765 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
 766 mkDftBackpermute ty idx src dft =
 767   do
 768     rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
 769     liftM snd $ mkBind FSLIT("dbp") rhs
 770
 771 -- create a dummy array with elements of the given type, which can be used as
 772 -- default array for the combination of the subresults of the lifted case
 773 -- expression
 774 --
 775 createDftArrayBind    :: CoreExpr -> Flatten CoreBind
 776 createDftArrayBind e  =
 777   panic "Flattening.createDftArrayBind: not implemented yet"
 778 {-
 779   do
 780     let ty = parrElemTy . exprType $ expr
 781     len <- mk'lengthP e
 782     rhs <- mk'replicateP ty len err??
 783     lift snd $ mkBind FSLIT("dft") rhs
 784 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
 785   beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
 786   generischen Wert f"ur jeden beliebigen Typ zu erfinden.
 787 -}
 788
 789
 790
 791
 792 -- show functions (the pretty print functions sometimes don't
 793 -- show it the way I want....
 794
 795 -- shows just the structure
 796 showCoreExpr (Var _ )    = "Var "
 797 showCoreExpr (Lit _) = "Lit "
 798 showCoreExpr (App e1 e2) =
 799   "(App \n  " ++ (showCoreExpr e1) ++ "\n  " ++ (showCoreExpr e2) ++ ") "
 800 showCoreExpr (Lam b e)   =
 801   "Lam b " ++ (showCoreExpr e)
 802 showCoreExpr (Let bnds expr) =
 803   "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
 804   where showBinds (NonRec b e) = showBind (b,e)
 805         showBinds (Rec bnds)   = concat (map showBind bnds)
 806         showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"
 807 -- gaw 2004 FIX?
 808 showCoreExpr (Case ex b ty alts) =
 809   "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
 810   where showAlts _ = ""
 811 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
 812 showCoreExpr (Type t) = "Type"