Commit 0c4f92f1 authored by bbr's avatar bbr
Browse files

initial commit in git repository

parents
1. run make
2. Hopefully, you will get the message that a file
.kicsrc has been written to your home directory.
You will need to edit this file according to your paths.
3. run make again
\ No newline at end of file
BIN = bin/
SRC = src/
LIB = $(SRC)lib/
DIST = dist/
THIS = ../kics/
KGHC = ghc --make -fglasgow-exts -i$(LIBS) -H500m
GHC = ghc --make -fglasgow-exts -i$(SRC) -H500m
LIBS = $(shell $(BIN)kicslib)
all: $(SRC)InstallDir.hs $(BIN)generate $(BIN)kicslib $(BIN)kics $(BIN)kicsi libs
.PHONY: tools
tools: $(SRC)InstallDir.hs $(BIN)makeExternalInterface
$(BIN)generate: $(SRC)InstallDir.hs $(SRC)Generate.hs $(SRC)CurryToHaskell.hs
$(GHC) $(SRC)Generate.hs -o $(BIN)generate
cd $(SRC)
$(BIN)generate $(SRC)
cd ..
$(SRC)InstallDir.hs:
echo "module InstallDir where" > $(SRC)InstallDir.hs
echo "installDir = \""`pwd`"\"" >> $(SRC)InstallDir.hs
$(BIN)kicslib: $(SRC)InstallDir.hs $(SRC)kicslib.hs $(SRC)Config.hs
mkdir -p bin
ghc -fglasgow-exts -i$(SRC) --make $(SRC)kicslib -o $(BIN)kicslib
$(BIN)makeExternalInterface: $(SRC)InstallDir.hs $(BIN)kicslib
$(KGHC) $(SRC)MakeExternalInterface -o $(BIN)makeExternalInterface
$(BIN)kicsi: $(BIN)kicslib $(SRC)CurryToHaskell.hs $(SRC)kicsi.hs
ifeq (,$(filter readline%,$(shell ghc-pkg list readline)))
@echo no readline package found
cp $(SRC)NoReadline.make $(SRC)MyReadline.hs
else
@echo readline package found
cp $(SRC)WithReadline.make $(SRC)MyReadline.hs
endif
$(KGHC) $(SRC)kicsi -o $(BIN)kicsi
$(BIN)kics: $(BIN)kicslib $(SRC)CurryToHaskell.hs
$(KGHC) $(SRC)kics -o $(BIN)kics
.PHONY: runtime
runtime: $(SRC)InstallDir.hs
$(KGHC) --make $(SRC)Curry.hs
.PHONY: libs
libs: $(BIN)kics runtime
$(BIN)kics -v -make $(LIB)All_Libraries
.PHONY: clean
clean:
rm -f *.o *.hi $(LIB)*.o $(LIB)*.hi $(SRC)*.o $(SRC)*.hi test/*.o test/*.hi
.PHONY: mrproper
mrproper: clean
rm -f $(SRC)InstallDir.hs
rm -f $(SRC)AutoGenerated*.hs
rm -f $(LIB)Curry*.hs $(LIB)Data*.hs $(LIB)Instances*.hs $(LIB)*.fcy $(LIB)*.fint\
test/Curry*.hs test/Data*.hs test/Instances*.hs test/*.fcy test/*.fint
.PHONY: dist
dist:
mkdir -p dist
rm -f $(SRC)InstallDir.hs
tar czf $(THIS)$(DIST)kics_src.tgz\
$(THIS)$(LIB)*.curry \
$(THIS)$(LIB)/ExternalData*.hs \
$(THIS)$(LIB)/ExternalInstances*.hs \
$(THIS)$(LIB)/ExternalFunctions*.hs \
$(THIS)$(LIB)/External*.spec \
$(THIS)$(SRC)*.hs\
$(THIS)$(SRC)*.make\
$(THIS)Makefile $(THIS)INSTALL\
$(THIS)$(BIN)kghc
cp $(THIS)$(DIST)kics_src.tgz ~/public_html/download/
chmod a+r ~/public_html/download/kics_src.tgz
#!/bin/sh
export KICS_LIB=`kicslib`
ghc --make -fglasgow-exts -i$KICS_LIB $@
\ No newline at end of file
module ArrayB where
import GHC.Exts hiding (split)
import Maybe
-- Implementation of Arrays with Braun Trees
infixl 9 !
data ArrayB b = Entry (Maybe b) (ArrayB b) (ArrayB b)
| Empty
deriving Eq
emptyArrayB :: ArrayB b
emptyArrayB = Entry Nothing emptyArrayB emptyArrayB
emptyArrayB' :: Word# -> Word# -> ArrayB b
emptyArrayB' b o =
Entry Nothing
(emptyArrayB' (timesWord# (int2Word# 2#) b) o)
(emptyArrayB' (timesWord# (int2Word# 2#) b) (plusWord# o b))
update :: ArrayB b -> Word# -> b -> ArrayB b
update (Entry v al ar) n v'
| eqWord# n (int2Word# 0#) = Entry (Just v') al ar
| otherwise =
let r = and# n (int2Word# (1#)) in
if eqWord# (int2Word# 0#) r
then Entry v al (update ar (minusWord# (div2 n) (int2Word# 1#)) v')
else Entry v (update al (div2 n) v') ar
div2 :: Word# -> Word#
div2 n = shiftRL# n 1#
(!) :: ArrayB b -> Word# -> (Maybe b)
(Entry v al ar) !n
| eqWord# n (int2Word# 0#) = v
| otherwise = let r = and# n (int2Word# (1#)) in
if eqWord# (int2Word# 0#) r
then ar!(minusWord# (div2 n) (int2Word# 1#))
else al!div2 n
Empty ! n = Nothing
split :: [a] -> ([a],[a])
split [] = ([],[])
split [x] = ([x],[])
split (x:y:xys) = let (xs,ys) = split xys in
(x:xs,y:ys)
listToArrayB :: [b] -> ArrayB b
listToArrayB xs = listToArrayB' (int2Word# 1#) (int2Word# 0#) xs
listToArrayB' :: Word# -> Word# -> [b] -> ArrayB b
listToArrayB' b o [] = Empty -- emptyArrayB' b o
listToArrayB' b o (x:xs) = let (ys,zs) = split xs in
Entry (Just x) (listToArrayB' (timesWord# (int2Word# 2#) b) o ys)
(listToArrayB' (timesWord# (int2Word# 2#) b) (plusWord# o b) zs)
rows k [] = []
rows k xs = let (ys,zs) = splitAt k xs in
(k,ys):rows (2*k) zs
built (k,xs) ts = zipWith3 Entry xs ts1 ts2
where (ts1,ts2) = splitAt k (ts++repeat Empty)
makeArray = head . foldr built [] . rows 1
module AutoGenerated1 (module AutoGenerated1) where
import Curry
data Prim t0 = PrimValue t0
| PrimFreeVar (FreeVarRef (Prim t0))
| PrimFail C_Exceptions
| PrimOr OrRef (Branches (Prim t0))
| PrimSusp SuspRef (SuspCont (Prim t0))
data C_Four = C_F0
| C_F1
| C_F2
| C_F3
| C_FourFreeVar (FreeVarRef C_Four)
| C_FourFail C_Exceptions
| C_FourOr OrRef (Branches C_Four)
| C_FourSusp SuspRef (SuspCont C_Four)
deriving (Eq)
module AutoGenerated2 (module AutoGenerated2) where
import Curry
import DataPrelude
instance BaseCurry C_Success where
nf f state x = f(state)(x)
gnf f state x = f(state)(x)
free _ = orsCTC([C_Success])
pattern _ = orsCTC([C_Success])
failed = C_SuccessFail
freeVar = C_SuccessFreeVar
branching = C_SuccessOr
suspend = C_SuccessSusp
consKind (C_SuccessFreeVar _) = Free
consKind (C_SuccessOr _ _) = Branching
consKind (C_SuccessFail _) = Failed
consKind (C_SuccessSusp _ _) = Suspended
consKind _ = Val
exceptions (C_SuccessFail x) = x
freeVarRef (C_SuccessFreeVar x) = x
orRef (C_SuccessOr x _) = x
branches (C_SuccessOr _ x) = x
suspRef (C_SuccessSusp x _) = x
suspCont (C_SuccessSusp _ x) = x
instance BaseCurry C_Bool where
nf f state x = f(state)(x)
gnf f state x = f(state)(x)
free _ = orsCTC([C_True,C_False])
pattern _ = orsCTC([C_True,C_False])
failed = C_BoolFail
freeVar = C_BoolFreeVar
branching = C_BoolOr
suspend = C_BoolSusp
consKind (C_BoolFreeVar _) = Free
consKind (C_BoolOr _ _) = Branching
consKind (C_BoolFail _) = Failed
consKind (C_BoolSusp _ _) = Suspended
consKind _ = Val
exceptions (C_BoolFail x) = x
freeVarRef (C_BoolFreeVar x) = x
orRef (C_BoolOr x _) = x
branches (C_BoolOr _ x) = x
suspRef (C_BoolSusp x _) = x
suspCont (C_BoolSusp _ x) = x
instance BaseCurry C_Four where
nf f state x = f(state)(x)
gnf f state x = f(state)(x)
free _ = orsCTC([C_F0,C_F1,C_F2,C_F3])
pattern _ = orsCTC([C_F0,C_F1,C_F2,C_F3])
failed = C_FourFail
freeVar = C_FourFreeVar
branching = C_FourOr
suspend = C_FourSusp
consKind (C_FourFreeVar _) = Free
consKind (C_FourOr _ _) = Branching
consKind (C_FourFail _) = Failed
consKind (C_FourSusp _ _) = Suspended
consKind _ = Val
exceptions (C_FourFail x) = x
freeVarRef (C_FourFreeVar x) = x
orRef (C_FourOr x _) = x
branches (C_FourOr _ x) = x
suspRef (C_FourSusp x _) = x
suspCont (C_FourSusp _ x) = x
op_38_38 :: State -> C_Bool -> C_Bool -> C_Bool
op_38_38 st x1@C_True x2 = x2
op_38_38 st x1@C_False x2 = C_False
op_38_38 st x@(C_BoolFreeVar ref) x2 = narrowCTC(st)(x)(\ st x -> op_38_38(st)(x)(x2))
op_38_38 st (C_BoolOr i xs) x2 = mapOr(st)(\ st x -> op_38_38(st)(x)(x2))(i)(xs)
op_38_38 st (C_BoolSusp ref susp) x2 = treatSusp(st)(\ st x -> op_38_38(st)(x)(x2))(ref)(susp)
op_38_38 st x x2 = patternFail("Generate.&&")(x)
module BaseCurry (module BaseCurry, module Store) where
import Store
import Data.IORef
import System.IO.Unsafe
-- On the top level io monad of each program we manage a store.
-- Because there is unsafe io and because some operations on
-- stores start out without one, a state might be without store.
type State = Maybe Store
-- curry data terms are classified into ConsKinds
data ConsKind = Val | Free | Branching | Suspended | Failed deriving (Show,Eq)
-- computations of (head) normal forms might residuate or not.
type HNFMode = Bool
-- for free vars
data FreeVarRef a = FreeVarRef Int (IORef a) deriving Eq
type Branches a = [a]
-- for suspensions
type SuspRef = Bool
type SuspCont a = IORef (() -> Maybe a)
data Exception
= ErrorCall String
| PatternMatchFail String
| AssertionFailed String
| IOException String deriving Eq
type C_Exceptions = Exception
type Fun a b = State -> a -> b
type Const a = State -> a
----------------------------------------------------------------
-- the BaseCurry class
----------------------------------------------------------------
class BaseCurry a where
-- computations of normal forms
nf :: BaseCurry b => (State -> a -> b) -> State -> a -> b
gnf :: BaseCurry b => (State -> a -> b) -> State -> a -> b
-- constructors
free :: () -> a
pattern :: () -> a
failed :: C_Exceptions -> a
freeVar :: FreeVarRef a -> a
branching :: OrRef -> Branches a -> a
suspend :: SuspRef -> SuspCont a -> a
-- category of given constructor
consKind :: a -> ConsKind
-- selectors
exceptions :: a -> C_Exceptions
freeVarRef :: a -> FreeVarRef a
orRef :: a -> OrRef
branches :: a -> Branches a
suspRef :: a -> SuspRef
suspCont :: a -> SuspCont a
-----------------------------------------
-- reading bindings for free variables
-----------------------------------------
binding :: BaseCurry a => a -> Either a a
binding v = unsafePerformIO (ioBinding v)
ioBinding :: BaseCurry a => a -> IO (Either a a)
ioBinding v = do
let FreeVarRef _ ref = freeVarRef v
b <- readIORef ref
case consKind b of
Failed -> return (Left v)
Free -> ioBinding b
_ -> return (Right b)
bind :: FreeVarRef a -> a -> b -> b
bind v val res = unsafePerformIO $ do
let FreeVarRef _ ref = v
writeIORef ref val
return res
------------------------------------------------------------------
-- implementation of call-time choice
------------------------------------------------------------------
-- This function controls all kinds of evaluations to (head) normal forms
-- IMPORTANT: if you change anything here, also update ExternalPrelude.prim_do
ctcStore :: (BaseCurry a,BaseCurry b) => HNFMode -> (State -> a -> b) -> State -> a -> b
ctcStore mode cont state x =
case consKind x of
-- cases solvable without store
Val -> cont state x
Failed -> addException (curryError ("Prelude."++if mode then "$#" else "$!")) x
Branching -> let ref = orRef x
bs = branches x
in case state of
Nothing -> mapOr state (ctcStore mode cont) ref bs
Just store -> case fromStore store ref of
Nothing -> branching ref
(zipWith (ctcBranch contCTC store ref) [0..] bs)
Just i -> ctcStore mode cont state (bs!!i)
Free -> let ref = freeVarRef x in
case binding x of
Left x' -> if mode then suspCTC Nothing (freeVarRef x') susp
else cont state x'
Right v -> ctcStore mode cont state v
Suspended -> treatSusp state (ctcStore mode cont) (suspRef x) (suspCont x)
{--- now we need to have the store
conskind -> case state of
Nothing -> fetchState (\st -> ctcStore mode cont st x)
Just store -> case conskind of
Suspended -> wakeUp contCTC (suspCont x) store-}
where
contCTC st = ctcStore mode cont (Just st)
susp = ctcStore mode cont
{-
-- It can happen that computations suspend twice in a row, e.g.:
-- let x,y free in x=:=1 &> y=:=2 &> (x+y)
-- that is what the SuspRef is needed for: Newly created suspensions have
-- a SuspRef=True, old ones a false susp ref.
-- Thus, when waking suspensions we need to repeat the process
-- until the susp ref is false (or we got a value).
wakeUp :: (BaseCurry a,BaseCurry b) => (Store -> a -> b) -> (SuspCont a) -> SuspCont b
wakeUp cont susp store = let x = susp store in
case consKind x of
Suspended -> if suspRef x then wakeUp cont (suspCont x) store
else suspend False (wakeUp cont (suspCont x))
_ -> cont store x
-- if we cannot find a binding in the store its still the old suspension.
findBind :: (BaseCurry a,BaseCurry b) => (Store -> a -> b) -> a -> SuspCont b
findBind cont ref store =
either (suspend False . findBind cont) (cont store) (binding ref)
-}
suspCTC :: (BaseCurry a,BaseCurry b) => State -> FreeVarRef a -> (State -> a -> b) -> b
suspCTC st ref cont = unsafePerformIO $ do
sr <- newIORef undefined
writeIORef sr (susp sr)
return (suspend True sr)
where
susp sr _ = unsafePerformIO $ do
b <- ioBinding (freeVar ref)
case b of
Left _ -> return Nothing
Right v -> do
let result = Just (cont st v)
writeIORef sr (const result)
return result
-- TODO: use state! also above!
-- maybe look at test susp: new state?
treatSusp :: (BaseCurry a,BaseCurry b) => State -> (State->a->b) -> SuspRef -> SuspCont a -> b
treatSusp st cont ref susp = unsafePerformIO $ do
waker <- readIORef susp
case waker () of
Just v -> return (cont st v)
Nothing -> do
sr <- newIORef undefined
writeIORef sr (testSusp sr)
return (suspend ref sr)
where
testSusp sr _ = unsafePerformIO $ do
waker <- readIORef susp
case waker () of
Nothing -> return Nothing
Just v -> do
let result = Just (cont st v)
writeIORef sr (const result)
return result
{-
-- retrieve state
-- As this suspension can directly be lifted upon getting the state, there
-- is no need to create a "suspend False" in any case.
fetchState :: BaseCurry a => (State -> a) -> a
fetchState cont = suspend True (cont . Just)
-}
-- pulling continuations into each branch of an or
ctcBranch :: (BaseCurry a, BaseCurry b) =>
(Store -> b -> a) -> Store -> OrRef -> Int -> b -> a
ctcBranch cont store orRef nr x =
let newStore = addToStore store orRef nr in
cont newStore x
-- pull continuations into branches without modifying a store
-- TODO: add right number to state!
mapOr :: (BaseCurry a,BaseCurry b) => State -> (State -> a -> b) -> OrRef -> Branches a -> b
mapOr Nothing f ref bs = mapOr (Just emptyStore) f ref bs
mapOr st@(Just store) f ref bs = case fromStore store ref of
Nothing -> branching ref
(zipWith (ctcBranch (f . Just) store ref) [0..] bs)
Just i -> f st (bs!!i)
addException :: (BaseCurry a,BaseCurry b) => Exception -> a -> b
addException _ x = failed (exceptions x)
curryError :: String -> Exception
curryError = ErrorCall
module Brace where
import List
separate :: [a] -> [[a]] -> [a]
separate s xs = concat (intersperse s (filter (not . null) xs))
brace :: [a] -> [a] -> [a] -> [[a]] -> [a]
brace _ _ _ [] = []
brace begin end sep xs = begin++separate sep xs++end
module Config where
import InstallDir
import SafeCalls
import XML
import Char
import System.Environment
import System.Directory hiding (executable)
import System.Time
import List
import FlatCurry(readFlatCurry)
import Names
getOptions :: IO Options
getOptions = do
(opts,_) <- readConfig
args <- getArgs
let newOpts = parseOptions opts args
either usage return newOpts
parseOptions :: Options -> [String] -> Either String Options
parseOptions opts [] = Left "no file name given"
parseOptions opts [x] = Right (opts{filename=x,mainModule=x})
parseOptions opts ("-or":xs) = parseOptions (opts{cm=OrBased}) xs
parseOptions opts ("-ctc":xs) = parseOptions (opts{cm=CTC}) xs
parseOptions opts ("-main":x:xs) = parseOptions (opts{mainFunc=x}) xs
parseOptions opts ("-frontend":x:xs) = parseOptions (opts{frontend=x}) xs
parseOptions opts ("-kicspath":x:xs) = parseOptions (opts{kicspath=x}) xs
parseOptions opts ("-userlibpath":x:xs) = parseOptions (opts{userlibpath=x}) xs
parseOptions opts ("-ghc":x:xs) = parseOptions (opts{ghc=x}) xs
parseOptions opts ("-frontendCall":x:xs) = parseOptions (opts{frontendCall=x}) xs
parseOptions opts ("-make":xs) = parseOptions (opts{make=True}) xs
parseOptions opts ("-nomake":xs) = parseOptions (opts{make=False}) xs
parseOptions opts ("-executable":xs) = parseOptions (opts{executable=True}) xs
parseOptions opts ("-noexecutable":xs) = parseOptions (opts{executable=False}) xs
parseOptions opts ("-q":xs) = parseOptions (opts{verbose=False}) xs
parseOptions opts ("-v":xs) = parseOptions (opts{verbose=True}) xs
parseOptions opts ("-noforce":xs) = parseOptions (opts{force=False}) xs
parseOptions opts ("-force":xs) = parseOptions (opts{force=True}) xs
parseOptions opts ("-all":"df":xs) = parseOptions (opts{pm=All DF}) xs
parseOptions opts ("-all":"bf":xs) = parseOptions (opts{pm=All BF}) xs
parseOptions opts ("-st":xs) = parseOptions (opts{pm=ST}) xs
parseOptions opts ("-i":"df":xs) = parseOptions (opts{pm=Interactive DF}) xs
parseOptions opts ("-i":"bf":xs) = parseOptions (opts{pm=Interactive BF}) xs
parseOptions opts ("-o":x:xs) = parseOptions (opts{target=x}) xs
parseOptions _ (x:_) = Left ("unrecognized option: "++x)
usage problem = do
putStrLn problem
putStrLn "Usage: kics [options] filename"
putStrLn "option | meaning"
putStrLn "-rtc | switch to run time choice"
putStrLn "-ctc | switch to call time choice"
putStrLn "-main | name of main function "
putStrLn "-frontend | path to frontend"
putStrLn "-kicspath | path to kics compiler"
putStrLn "-userlibpath | path to curry libraries"
putStrLn "-ghc | path to ghc"
putStrLn "-frontendCall | name of frontend"
putStrLn "-make | chase imported modules"
putStrLn "-nomake | do not chase imported modules"
putStrLn "-executable | create executable"
putStrLn "-noexecutable | do not create executable"
putStrLn "-v | verbose output"
putStrLn "-q | scarce output"
putStrLn "-force | force recompilation"
putStrLn "-noforce | do not force recompilation"
putStrLn "-all df | print all solutions depth first"
putStrLn "-all bf | print all solutions breadth first"
putStrLn "-st | print solutions as search tree"