VECTORISE pragmas for type classes and instances
[ghc.git] / compiler / typecheck / TcHsSyn.lhs
index 7692271..f805720 100644 (file)
@@ -1,4 +1,4 @@
-1%
+%
 % (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1996-1998
 %
@@ -35,6 +35,7 @@ import TcRnMonad
 import PrelNames
 import TcType
 import TcMType
+import Coercion
 import TysPrim
 import TysWiredIn
 import DataCon
@@ -43,14 +44,15 @@ import NameSet
 import Var
 import VarSet
 import VarEnv
+import DynFlags
 import Literal
 import BasicTypes
 import Maybes
 import SrcLoc
-import DynFlags( DynFlag(..) )
 import Bag
 import FastString
 import Outputable
+-- import Data.Traversable( traverse )
 \end{code}
 
 \begin{code}
@@ -105,6 +107,8 @@ hsLitType (HsStringPrim _) = addrPrimTy
 hsLitType (HsInt _)        = intTy
 hsLitType (HsIntPrim _)    = intPrimTy
 hsLitType (HsWordPrim _)   = wordPrimTy
+hsLitType (HsInt64Prim _)  = int64PrimTy
+hsLitType (HsWord64Prim _) = word64PrimTy
 hsLitType (HsInteger _ ty) = ty
 hsLitType (HsRat _ ty)     = ty
 hsLitType (HsFloatPrim _)  = floatPrimTy
@@ -119,7 +123,7 @@ shortCutLit (HsIntegral i) ty
   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
   | isIntegerTy ty              = Just (HsLit (HsInteger i ty))
-  | otherwise                   = shortCutLit (HsFractional (fromInteger i)) ty
+  | otherwise                   = shortCutLit (HsFractional (integralFractionalLit i)) ty
        -- The 'otherwise' case is important
        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
        -- so we'll call shortCutIntLit, but of course it's a float
@@ -282,7 +286,7 @@ zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
 
         -- Warn about missing signatures
         -- Do this only when we we have a type to offer
-        ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
+        ; warn_missing_sigs <- woptM Opt_WarnMissingSigs
         ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
                        | otherwise         = noSigWarn
 
@@ -303,7 +307,7 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
   = panic "zonkLocalBinds" -- Not in typechecker output
 
 zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
-  = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs
+  = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
         ; let sig_warn | not warn_missing_sigs = noSigWarn
                        | otherwise             = localSigWarn sig_ns
               sig_ns = getTypeSigNames vb
@@ -421,15 +425,17 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
            ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
            ; new_exports   <- mapM (zonkExport env3) exports
            ; return (new_val_binds, new_exports) } 
-       ; sig_warn True [b | (_,b,_,_) <- new_exports]
+       ; sig_warn True (map abe_poly new_exports)
        ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
   where
-    zonkExport env (tyvars, global, local, prags)
-       -- The tyvars are already zonked
-       = zonkIdBndr env global                 `thenM` \ new_global ->
-         zonkSpecPrags env prags               `thenM` \ new_prags -> 
-         returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
+    zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
+                       , abe_mono = mono_id, abe_prags = prags })
+       = zonkIdBndr env poly_id                `thenM` \ new_poly_id ->
+         zonkCoFn env wrap                     `thenM` \ (_, new_wrap) ->
+          zonkSpecPrags env prags              `thenM` \ new_prags -> 
+         returnM (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
+                      , abe_mono = zonkIdOcc env mono_id, abe_prags = new_prags })
 
 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
 zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
@@ -675,8 +681,8 @@ zonkCoFn env WpHole   = return (env, WpHole)
 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
                                    ; (env2, c2') <- zonkCoFn env1 c2
                                    ; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
-                                ; return (env, WpCast co') }
+zonkCoFn env (WpCast co) = do { co' <- zonkTcLCoToLCo env co
+                             ; return (env, WpCast co') }
 zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
                                 ; return (env', WpEvLam ev') }
 zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg 
@@ -773,29 +779,20 @@ zonkStmt env (LastStmt expr ret_op)
     zonkExpr env ret_op                `thenM` \ new_ret ->
     returnM (env, LastStmt new_expr new_ret)
 
-zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op)
-  = do { (env', stmts') <- zonkStmts env stmts 
-    ; let binders' = zonkIdOccs env' binders
-    ; usingExpr' <- zonkLExpr env' usingExpr
-    ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
-    ; return_op' <- zonkExpr env' return_op
-    ; bind_op' <- zonkExpr env' bind_op
-    ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op') }
-    
-zonkStmt env (GroupStmt { grpS_stmts = stmts, grpS_bndrs = binderMap
-                        , grpS_by = by, grpS_explicit = explicit, grpS_using = using
-                        , grpS_ret = return_op, grpS_bind = bind_op, grpS_fmap = liftM_op })
+zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+                        , trS_by = by, trS_form = form, trS_using = using
+                        , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
   = do { (env', stmts') <- zonkStmts env stmts 
     ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
-    ; by' <- fmapMaybeM (zonkLExpr env') by
-    ; using' <- zonkLExpr env using
+    ; by'        <- fmapMaybeM (zonkLExpr env') by
+    ; using'     <- zonkLExpr env using
     ; return_op' <- zonkExpr env' return_op
-    ; bind_op' <- zonkExpr env' bind_op
-    ; liftM_op' <- zonkExpr env' liftM_op
+    ; bind_op'   <- zonkExpr env' bind_op
+    ; liftM_op'  <- zonkExpr env' liftM_op
     ; let env'' = extendZonkEnv env' (map snd binderMap')
-    ; return (env'', GroupStmt { grpS_stmts = stmts', grpS_bndrs =  binderMap'
-                               , grpS_by = by', grpS_explicit = explicit, grpS_using = using'
-                               , grpS_ret = return_op', grpS_bind = bind_op', grpS_fmap = liftM_op' }) }
+    ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+                               , trS_by = by', trS_form = form, trS_using = using'
+                               , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
   where
     zonkBinderMapEntry env (oldBinder, newBinder) = do 
         let oldBinder' = zonkIdOcc env oldBinder
@@ -813,11 +810,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op)
        ; new_fail <- zonkExpr env fail_op
        ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
 
-zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
-zonkMaybeLExpr _   Nothing  = return Nothing
-zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
-
-
 -------------------------------------------------------------------------
 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
 zonkRecFields env (HsRecFields flds dd)
@@ -972,8 +964,8 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
 
 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i _hs_ty spec) =
-   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
+zonkForeignExport env (ForeignExport i _hs_ty co spec) =
+   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
 zonkForeignExport _ for_imp 
   = returnM for_imp    -- Foreign imports don't need zonking
 \end{code}
@@ -1022,7 +1014,6 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
-     | isCoVar v  = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
@@ -1031,15 +1022,24 @@ zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
 zonkVects env = mappM (wrapLocM (zonkVect env))
 
 zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
-zonkVect env (HsVect v Nothing)
+zonkVect env (HsVect v e)
   = do { v' <- wrapLocM (zonkIdBndr env) v
-       ; return $ HsVect v' Nothing
+       ; e' <- fmapMaybeM (zonkLExpr env) e
+       ; return $ HsVect v' e'
        }
-zonkVect env (HsVect v (Just e))
+zonkVect env (HsNoVect v)
   = do { v' <- wrapLocM (zonkIdBndr env) v
-       ; e' <- zonkLExpr env e
-       ; return $ HsVect v' (Just e')
+       ; return $ HsNoVect v'
        }
+zonkVect _env (HsVectTypeOut s t rt)
+  = return $ HsVectTypeOut s t rt
+zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
+zonkVect _env (HsVectClassOut c)
+  = return $ HsVectClassOut c
+zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
+zonkVect _env (HsVectInstOut s i)
+  = return $ HsVectInstOut s i
+zonkVect _ (HsVectInstIn _ _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
 \end{code}
 
 %************************************************************************
@@ -1052,11 +1052,13 @@ zonkVect env (HsVect v (Just e))
 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
                                     return (EvId (zonkIdOcc env v))
-zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcTypeToType env co
-                                       ; return (EvCoercion co') }
+zonkEvTerm env (EvCoercionBox co) = do { co' <- zonkTcLCoToLCo env co
+                                       ; return (EvCoercionBox co') }
 zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
-                                    do { co' <- zonkTcTypeToType env co
+                                    do { co' <- zonkTcLCoToLCo env co
                                        ; return (EvCast (zonkIdOcc env v) co') }
+zonkEvTerm env (EvTupleSel v n)   = return (EvTupleSel (zonkIdOcc env v) n)
+zonkEvTerm env (EvTupleMk vs)     = return (EvTupleMk (map (zonkIdOcc env) vs))
 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
 zonkEvTerm env (EvDFunApp df tys tms)
   = do { tys' <- zonkTcTypeToTypes env tys
@@ -1130,4 +1132,27 @@ zonkTypeZapping ty
     zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
                               ; writeMetaTyVar tv ty
                               ; return ty }
+
+zonkTcLCoToLCo :: ZonkEnv -> LCoercion -> TcM LCoercion
+zonkTcLCoToLCo env co
+  = go co
+  where
+    go (CoVarCo cv)         = return (CoVarCo (zonkEvVarOcc env cv))
+    go (Refl ty)            = do { ty' <- zonkTcTypeToType env ty
+                                 ; return (Refl ty') }
+    go (TyConAppCo tc cos)  = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') }
+    go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') }
+    go (AppCo co1 co2)      = do { co1' <- go co1; co2' <- go co2
+                                 ; return (mkAppCo co1' co2') }
+    go (UnsafeCo t1 t2)     = do { t1' <- zonkTcTypeToType env t1
+                                 ; t2' <- zonkTcTypeToType env t2
+                                 ; return (mkUnsafeCo t1' t2') }
+    go (SymCo co)           = do { co' <- go co; return (mkSymCo co')  }
+    go (NthCo n co)         = do { co' <- go co; return (mkNthCo n co')  }
+    go (TransCo co1 co2)    = do { co1' <- go co1; co2' <- go co2
+                                 ; return (mkTransCo co1' co2')  }
+    go (InstCo co ty)       = do { co' <- go co; ty' <- zonkTcTypeToType env ty
+                                 ; return (mkInstCo co' ty')  }
+    go (ForAllCo tv co)     = ASSERT( isImmutableTyVar tv )
+                              do { co' <- go co; return (mkForAllCo tv co') }
 \end{code}