Commit 1d61cbfa authored by Finn Teegen's avatar Finn Teegen
Browse files

Fix arity in IL and use that arity for FC generation

parent bc70f8f3
......@@ -45,7 +45,6 @@ import Base.Types
import CompilerEnv
import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv, tcKind)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import qualified IL
import Transformations (transType)
......@@ -109,7 +108,6 @@ data FlatEnv = FlatEnv
, 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
, typeSynonyms :: [CS.Decl Type] -- type synonyms
, imports :: [ModuleIdent] -- module imports
......@@ -132,7 +130,6 @@ run env (CS.Module _ _ _ mid es is ds) act = S.evalState act env0
-- 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 (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o)
......@@ -161,15 +158,6 @@ 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 ("GenTypeAnnotatedFlatCurry.getArity: " ++ qualName qid)
getFixities :: FlatState [CS.IDecl]
getFixities = S.gets fixities
......@@ -332,14 +320,12 @@ cvFixity CS.Infix = InfixOp
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]
trAFuncDecl (IL.FunctionDecl f vs ty e) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trARule ty vs e
return [AFunc f' a vis ty' r']
trAFuncDecl (IL.ExternalDecl f ty) = do
return [AFunc f' (length vs) vis ty' r']
trAFuncDecl (IL.ExternalDecl f a ty) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
ty' <- trType ty
r' <- trAExternal ty f
......@@ -361,8 +347,8 @@ trAExternal ty f = flip AExternal (qualName f) <$> trType ty
trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)
trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l
trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v
trAExpr (IL.Function ty f _) = genCall Fun ty f []
trAExpr (IL.Constructor ty c _) = genCall Con ty c []
trAExpr (IL.Function ty f a) = genCall Fun ty f a []
trAExpr (IL.Constructor ty c a) = genCall Con ty c a []
trAExpr (IL.Apply e1 e2) = trApply e1 e2
trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e
<*> mapM (inNestedEnv . trAlt) bs
......@@ -400,8 +386,8 @@ 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
IL.Function ty f a -> genCall Fun ty f a es
IL.Constructor ty c a -> genCall Con ty c a es
_ -> do
expr <- trAExpr e
genApply expr es
......@@ -426,11 +412,10 @@ cvEval IL.Flex = Flex
data Call = Fun | Con
-- Generate a function or constructor call
genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]
genCall :: Call -> IL.Type -> QualIdent -> Int -> [IL.Expression]
-> FlatState (AExpr TypeExpr)
genCall call ty f es = do
genCall call ty f arity es = do
f' <- trQualIdent f
arity <- getArity f
case compare supplied arity of
LT -> genAComb ty f' es (part call (arity - supplied))
EQ -> genAComb ty f' es (full call)
......
......@@ -336,7 +336,7 @@ trTFuncDecl (IL.FunctionDecl f vs ty e) = do
ty' <- trType ty
r' <- trTRule vs e
return [TFunc f' a vis ty' r']
trTFuncDecl (IL.ExternalDecl f ty) = do
trTFuncDecl (IL.ExternalDecl f _ ty) = do
f' <- trQualIdent f
a <- getArity f
vis <- getVisibility f
......
......@@ -68,7 +68,7 @@ ppDecl (ExternalDataDecl tc ks) =
ppDecl (FunctionDecl f vs ty e) = ppTypeSig f ty $$ sep
[ ppQIdent f <+> hsep (map (ppIdent . snd) vs) <+> equals
, nest bodyIndent (ppExpr 0 e)]
ppDecl (ExternalDecl f ty) = text "external" <+> ppTypeSig f ty
ppDecl (ExternalDecl f _ ty) = text "external" <+> ppTypeSig f ty
ppTypeLhs :: QualIdent -> Int -> Doc
ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))
......
......@@ -57,9 +57,10 @@ showsDecl (FunctionDecl qident idents typ expr)
. showsType typ . space
. showsExpression expr
. showsString ")"
showsDecl (ExternalDecl qident typ)
showsDecl (ExternalDecl qident arity typ)
= showsString "(ExternalDecl "
. showsQualIdent qident . space
. shows arity
. showsType typ
. showsString ")"
......
......@@ -62,7 +62,7 @@ data Decl
| NewtypeDecl QualIdent [Kind] NewConstrDecl
| ExternalDataDecl QualIdent [Kind]
| FunctionDecl QualIdent [(Type, Ident)] Type Expression
| ExternalDecl QualIdent Type
| ExternalDecl QualIdent Int Type
deriving (Eq, Show)
data NewConstrDecl = NewConstrDecl QualIdent Type
......
......@@ -101,7 +101,7 @@ ccDecl :: Decl -> CCM Decl
ccDecl dd@(DataDecl _ _ _) = return dd
ccDecl edd@(ExternalDataDecl _ _) = return edd
ccDecl (FunctionDecl qid vs ty e) = FunctionDecl qid vs ty <$> ccExpr e
ccDecl ed@(ExternalDecl _ _) = return ed
ccDecl ed@(ExternalDecl _ _ _) = return ed
ccDecl nd@(NewtypeDecl _ _ _) = return nd
ccExpr :: Expression -> CCM Expression
......
......@@ -75,7 +75,7 @@ mdlsDecl (IL.NewtypeDecl _ _ nc) ms = mdlsNewConstrDecl nc
where mdlsNewConstrDecl (IL.NewConstrDecl _ ty) = mdlsType ty ms
mdlsDecl (IL.ExternalDataDecl _ _) ms = ms
mdlsDecl (IL.FunctionDecl _ _ ty e) ms = mdlsType ty (mdlsExpr e ms)
mdlsDecl (IL.ExternalDecl _ ty) ms = mdlsType ty ms
mdlsDecl (IL.ExternalDecl _ _ ty) ms = mdlsType ty ms
mdlsType :: IL.Type -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsType (IL.TypeConstructor tc tys) ms = modules tc (foldr mdlsType ms tys)
......@@ -125,14 +125,16 @@ getTCEnv = R.asks tyconEnv
trQualify :: Ident -> TransM QualIdent
trQualify i = flip qualifyWith i <$> R.asks moduleIdent
-- Return the type of a variable
varType :: QualIdent -> TransM Type
varType f = do
tyEnv <- getValueEnv
case qualLookupValue f tyEnv of
[Value _ _ _ (ForAll _ (PredType _ ty))] -> return ty
[Label _ _ (ForAll _ (PredType _ ty))] -> return ty
_ -> internalError $ "CurryToIL.varType: " ++ show f
getArity :: QualIdent -> TransM Int
getArity qid = do
vEnv <- getValueEnv
return $ case qualLookupValue qid vEnv of
[DataConstructor _ a _ _] -> a
[NewtypeConstructor _ _ _] -> 1
[Value _ _ a _] -> a
[Label _ _ _] -> 1
_ ->
internalError $ "CurryToIL.getArity: " ++ show qid
-- Return the type of a constructor
constrType :: QualIdent -> TransM Type
......@@ -215,7 +217,8 @@ trExternal :: Var Type -> TransM IL.Decl
trExternal (Var ty f) = do
tcEnv <- getTCEnv
f' <- trQualify f
return $ IL.ExternalDecl f' (transType tcEnv $ polyType ty)
a <- getArity f'
return $ IL.ExternalDecl f' a (transType tcEnv $ polyType ty)
-- The type representation in the intermediate language does not support
-- types with higher order kinds. Therefore, the type transformations has
......@@ -422,10 +425,10 @@ trExpr _ env (Variable _ ty v)
Nothing -> fun tcEnv
Just v' -> return $ IL.Variable (transType tcEnv ty) v' -- apply renaming
where
fun tcEnv = (IL.Function (transType tcEnv ty) v . arrowArity) <$> varType v
fun tcEnv = IL.Function (transType tcEnv ty) v <$> getArity v
trExpr _ _ (Constructor _ ty c) = do
tcEnv <- getTCEnv
(IL.Constructor (transType tcEnv ty) c . arrowArity) <$> constrType c
IL.Constructor (transType tcEnv ty) c <$> getArity c
trExpr vs env (Apply _ e1 e2)
= IL.Apply <$> trExpr vs env e1 <*> trExpr vs env e2
trExpr vs env (Let _ _ ds e) = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment