Commit b2465b9f authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Added support for untyped AbstractCurry

parent 53c64683
......@@ -147,6 +147,7 @@ data TargetType
| FlatCurry -- ^ FlatCurry
| ExtendedFlatCurry -- ^ Extended FlatCurry
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
deriving (Eq, Show)
-- |Warnings flags
......@@ -366,6 +367,10 @@ options =
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ AbstractCurry : optTargetTypes opts }))
"generate (type infered) AbstractCurry code"
, Option "" ["uacy"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ UntypedAbstractCurry : optTargetTypes opts }))
"generate untyped AbstractCurry code"
, Option "F" []
(NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
"use custom preprocessor"
......
......@@ -163,6 +163,7 @@ process opts idx m fn deps
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
]
......
......@@ -23,9 +23,13 @@ import CompilerEnv
import IL (Module)
import ModuleSummary
-- |Generate AbstractCurry
genAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genAbstractCurry = GAC.genAbstractCurry
-- |Generate typed AbstractCurry
genTypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genTypedAbstractCurry = GAC.genAbstractCurry False
-- |Generate untyped AbstractCurry
genUntypedAbstractCurry :: CompilerEnv -> CS.Module -> AC.CurryProg
genUntypedAbstractCurry = GAC.genAbstractCurry True
-- |Generate FlatCurry
genFlatCurry :: ModuleSummary -> CompilerEnv -> IL.Module -> EF.Prog
......
......@@ -16,10 +16,13 @@
module Generators.GenAbstractCurry (genAbstractCurry) where
import Control.Applicative
import qualified Control.Monad.State as S (State, evalState, get, gets, modify
, put)
import qualified Data.Set as Set (Set, empty, insert, member)
import qualified Data.Traversable as T (forM)
import qualified Control.Monad.State as S (State, evalState, get, gets
, modify, put, when)
import qualified Data.Map as Map (Map, empty, fromList, lookup
, union)
import qualified Data.Maybe as Maybe (fromMaybe)
import qualified Data.Set as Set (Set, empty, insert, member)
import qualified Data.Traversable as T (forM)
import Curry.AbstractCurry
import Curry.Base.Ident
......@@ -44,8 +47,10 @@ type GAC a = S.State AbstractEnv a
-- ---------------------------------------------------------------------------
-- |Generate an AbstractCurry program term from the syntax tree
genAbstractCurry :: CompilerEnv -> Module -> CurryProg
genAbstractCurry env mdl = S.evalState (trModule mdl) (abstractEnv env mdl)
-- when uacy flag is set untype AbstractCurry is generated
genAbstractCurry :: Bool -> CompilerEnv -> Module -> CurryProg
genAbstractCurry uacy env mdl
= S.evalState (trModule mdl) (abstractEnv uacy env mdl)
-- ---------------------------------------------------------------------------
-- Conversion from Curry to AbstractCurry
......@@ -168,8 +173,19 @@ trLocalDecl (PatternDecl _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])
<$> trPat p <*> trRhs rhs
trLocalDecl (FreeDecl _ vs) = (\vs' -> [CLocalVars vs'])
<$> mapM getVarIndex vs
trLocalDecl s@(TypeSig _ _ _) = do
uacy <- S.gets untypedAcy
S.when uacy (insertSig s)
return []
trLocalDecl _ = return [] -- can not occur (types etc.)
insertSig :: Decl -> GAC ()
insertSig (TypeSig _ fs ty) = do
sigs <- S.gets typeSigs
let lsigs = Map.fromList [(f, ty) | f <- fs]
S.modify $ \env -> env { typeSigs = sigs `Map.union` lsigs }
insertSig _ = return ()
trExpr :: Expression -> GAC CExpr
trExpr (Literal l) = return (CLit $ cvLiteral l)
trExpr (Variable v)
......@@ -316,6 +332,9 @@ qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
qIfThenElseId :: QualIdent
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
prelUntyped :: QualIdent
prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"
-- Checks, whether a symbol is defined in the Prelude.
isPreludeSymbol :: QualIdent -> Bool
isPreludeSymbol qid
......@@ -330,25 +349,32 @@ isPreludeSymbol qid
-- |Data type for representing an AbstractCurry generator environment
data AbstractEnv = AbstractEnv
{ moduleId :: ModuleIdent -- ^name of the module
, typeEnv :: ValueEnv -- ^known values
, exports :: Set.Set Ident -- ^exported symbols
, varIndex :: Int -- ^counter for variable indices
, tvarIndex :: Int -- ^counter for type variable indices
, varEnv :: NestEnv Int -- ^stack of variable tables
, tvarEnv :: TopEnv Int -- ^stack of type variable tables
{ moduleId :: ModuleIdent -- ^name of the module
, typeEnv :: ValueEnv -- ^known values
, exports :: Set.Set Ident -- ^exported symbols
, varIndex :: Int -- ^counter for variable indices
, tvarIndex :: Int -- ^counter for type variable indices
, varEnv :: NestEnv Int -- ^stack of variable tables
, tvarEnv :: TopEnv Int -- ^stack of type variable tables
, untypedAcy :: Bool -- ^flag to indicate whether untyped
-- AbstractCurry is generated
, typeSigs :: Map.Map Ident TypeExpr -- ^map of user defined type signatures
} deriving Show
-- |Initialize the AbstractCurry generator environment
abstractEnv :: CompilerEnv -> Module -> AbstractEnv
abstractEnv env (Module _ mid es _ _) = AbstractEnv
{ moduleId = mid
, typeEnv = valueEnv env
, exports = foldr (buildExportTable mid) Set.empty es'
, varIndex = 0
, tvarIndex = 0
, varEnv = globalEnv emptyTopEnv
, tvarEnv = emptyTopEnv
abstractEnv :: Bool -> CompilerEnv -> Module -> AbstractEnv
abstractEnv uacy env (Module _ mid es _ ds) = AbstractEnv
{ moduleId = mid
, typeEnv = valueEnv env
, exports = foldr (buildExportTable mid) Set.empty es'
, varIndex = 0
, tvarIndex = 0
, varEnv = globalEnv emptyTopEnv
, tvarEnv = emptyTopEnv
, untypedAcy = uacy
, typeSigs = if uacy then Map.fromList [ (f, ty) | TypeSig _ fs ty <- ds
, f <- fs]
else Map.empty
}
where es' = case es of
Just (Exporting _ e) -> e
......@@ -436,7 +462,13 @@ getArity f = do
_ -> internalError $ "GenAbstractCurry.getArity: " ++ show f
getType :: Ident -> GAC TypeExpr
getType f = do
getType f = S.gets untypedAcy >>= getType' f
getType' :: Ident -> Bool -> GAC TypeExpr
getType' f True = do
sigs <- S.gets typeSigs
return $ Maybe.fromMaybe (ConstructorType prelUntyped []) (Map.lookup f sigs)
getType' f False = do
m <- S.gets moduleId
tyEnv <- S.gets typeEnv
return $ case lookupValue f tyEnv of
......
......@@ -328,10 +328,13 @@ writeFlatIntf opts fn env modSum il
writeAbstractCurry :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeAbstractCurry opts fname (env, modul) = do
when acyTarget $ AC.writeCurry (useSubDir $ acyName fname)
$ genAbstractCurry env modul
when acyTarget $ AC.writeCurry (useSubDir $ acyName fname)
$ genTypedAbstractCurry env modul
when uacyTarget $ AC.writeCurry (useSubDir $ uacyName fname)
$ genUntypedAbstractCurry env modul
where
acyTarget = AbstractCurry `elem` optTargetTypes opts
uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
type Dump = (DumpLevel, CompilerEnv, String)
......
f :: Int -> Int
f x = x + 1
g y = h y * k y
where
h :: Int -> Int
h a = a * 2
k b = b `div` 2
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