Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
0c73c54d
Commit
0c73c54d
authored
Jan 26, 2008
by
twanvl
Browse files
Fixed warnings in vectorise/VectUtils
parent
22b2f408
Changes
1
Hide whitespace changes
Inline
Side-by-side
compiler/vectorise/VectUtils.hs
View file @
0c73c54d
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module
VectUtils
(
collectAnnTypeBinders
,
collectAnnTypeArgs
,
isAnnTypeArg
,
collectAnnValBinders
,
...
...
@@ -41,18 +34,15 @@ import DataCon
import
Var
import
Id
(
mkWildId
)
import
MkId
(
unwrapFamInstScrut
)
import
Name
(
Name
)
import
PrelNames
import
TysWiredIn
import
TysPrim
(
intPrimTy
)
import
BasicTypes
(
Boxity
(
..
)
)
import
Literal
(
Literal
,
mkMachInt
)
import
Outputable
import
FastString
import
Data.List
(
zipWith4
)
import
Control.Monad
(
liftM
,
liftM2
,
zipWithM_
)
import
Control.Monad
collectAnnTypeArgs
::
AnnExpr
b
ann
->
(
AnnExpr
b
ann
,
[
Type
])
collectAnnTypeArgs
expr
=
go
expr
[]
...
...
@@ -73,7 +63,7 @@ collectAnnValBinders expr = go [] expr
go
bs
e
=
(
reverse
bs
,
e
)
isAnnTypeArg
::
AnnExpr
b
ann
->
Bool
isAnnTypeArg
(
_
,
AnnType
t
)
=
True
isAnnTypeArg
(
_
,
AnnType
_
)
=
True
isAnnTypeArg
_
=
False
dataConTagZ
::
DataCon
->
Int
...
...
@@ -107,9 +97,10 @@ mkBuiltinTyConApps get_tc tys ty
where
mk
tc
ty1
ty2
=
mkTyConApp
tc
[
ty1
,
ty2
]
{-
mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
mkBuiltinTyConApps1
get_tc
dft
[]
=
return
dft
mkBuiltinTyConApps1
get_tc
dft
tys
mkBuiltinTyConApps1
_
dft [] = return dft
mkBuiltinTyConApps1 get_tc
_
tys
= do
tc <- builtin get_tc
case tys of
...
...
@@ -120,6 +111,7 @@ mkBuiltinTyConApps1 get_tc dft tys
mkClosureType :: Type -> Type -> VM Type
mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
-}
mkClosureTypes
::
[
Type
]
->
Type
->
VM
Type
mkClosureTypes
=
mkBuiltinTyConApps
closureTyCon
...
...
@@ -183,7 +175,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
|
isLiftedTypeKind
k
=
liftM
Just
(
mkPADictType
ty
)
go
ty
k
=
return
Nothing
go
_
_
=
return
Nothing
paDictOfType
::
Type
->
VM
CoreExpr
paDictOfType
ty
=
paDictOfTyApp
ty_fn
ty_args
...
...
@@ -201,7 +193,7 @@ paDictOfTyApp (TyConApp tc _) ty_args
=
do
dfun
<-
traceMaybeV
"paDictOfTyApp"
(
ppr
tc
)
(
lookupTyConPA
tc
)
paDFunApply
(
Var
dfun
)
ty_args
paDictOfTyApp
ty
ty_args
=
pprPanic
"paDictOfTyApp"
(
ppr
ty
)
paDictOfTyApp
ty
_
=
pprPanic
"paDictOfTyApp"
(
ppr
ty
)
paDFunType
::
TyCon
->
VM
Type
paDFunType
tc
...
...
@@ -222,20 +214,21 @@ paDFunApply dfun tys
type
PAMethod
=
(
Builtins
->
Var
,
String
)
pa_length
,
pa_replicate
,
pa_empty
,
pa_pack
::
(
Builtins
->
Var
,
String
)
pa_length
=
(
lengthPAVar
,
"lengthPA"
)
pa_replicate
=
(
replicatePAVar
,
"replicatePA"
)
pa_empty
=
(
emptyPAVar
,
"emptyPA"
)
pa_pack
=
(
packPAVar
,
"packPA"
)
paMethod
::
PAMethod
->
Type
->
VM
CoreExpr
paMethod
(
method
,
name
)
ty
paMethod
(
_
method
,
name
)
ty
|
Just
tycon
<-
splitPrimTyCon
ty
=
do
fn
<-
traceMaybeV
"paMethod"
(
ppr
tycon
<+>
text
name
)
$
lookupPrimMethod
tycon
name
return
(
Var
fn
)
paMethod
(
method
,
name
)
ty
paMethod
(
method
,
_
name
)
ty
=
do
fn
<-
builtin
method
dict
<-
paDictOfType
ty
...
...
@@ -346,6 +339,7 @@ takeHoisted
setGEnv
$
env
{
global_bindings
=
[]
}
return
$
global_bindings
env
{-
boxExpr :: Type -> VExpr -> VM VExpr
boxExpr ty (vexpr, lexpr)
| Just (tycon, []) <- splitTyConApp_maybe ty
...
...
@@ -357,7 +351,7 @@ boxExpr ty (vexpr, lexpr)
in
return (mkConApp dc [vexpr], lexpr)
Nothing -> return (vexpr, lexpr)
-}
mkClosure
::
Type
->
Type
->
Type
->
VExpr
->
VExpr
->
VM
VExpr
mkClosure
arg_ty
res_ty
env_ty
(
vfn
,
lfn
)
(
venv
,
lenv
)
...
...
@@ -377,7 +371,7 @@ mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
Var
lapply
`
mkTyApps
`
[
arg_ty
,
res_ty
]
`
mkApps
`
[
lclo
,
larg
])
buildClosures
::
[
TyVar
]
->
[
VVar
]
->
[
Type
]
->
Type
->
VM
VExpr
->
VM
VExpr
buildClosures
tvs
vars
[]
res_ty
mk_body
buildClosures
_
_
[]
_
mk_body
=
mk_body
buildClosures
tvs
vars
[
arg_ty
]
res_ty
mk_body
=
buildClosure
tvs
vars
arg_ty
res_ty
mk_body
...
...
@@ -431,7 +425,7 @@ buildEnv vvs
tys
=
map
idType
vs
mkVectEnv
::
[
Type
]
->
[
Var
]
->
(
Type
,
CoreExpr
,
CoreExpr
->
CoreExpr
->
CoreExpr
)
mkVectEnv
[]
[]
=
(
unitTy
,
Var
unitDataConId
,
\
env
body
->
body
)
mkVectEnv
[]
[]
=
(
unitTy
,
Var
unitDataConId
,
\
_
body
->
body
)
mkVectEnv
[
ty
]
[
v
]
=
(
ty
,
Var
v
,
\
env
body
->
Let
(
NonRec
v
env
)
body
)
mkVectEnv
tys
vs
=
(
ty
,
mkCoreTup
(
map
Var
vs
),
\
env
body
->
Case
env
(
mkWildId
ty
)
(
exprType
body
)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment