{-
Besides other things it implements the MAGIC of some function definitions.
Occurrences of these functions (in specific contexts) are turned into
a respective bytecode.
-}
module PrimCode(primCode{-,rpsEval-},rpsseq) where
import Util.Extra(pair)
import State
import IntState
import TokenId
import PosCode
import SysDeps(PackedString,packString)
import IdKind
import Id(Id)
import Building (Compiler(..),compiler)
type PrimDown = ((Bool, Bool, Bool), Bool, Bool, Id)
type PrimMonad a b = State PrimDown
(IntState, [(a, PosLambda)])
b
(IntState, [(a, PosLambda)])
------- (true if bool == Int, true if && || not is primitives,true if )
primCode :: (Bool,Bool,Bool) -- ^ bool, logic, always [too cryptic!]
-> Bool -- ^ magic: create byte code instructions for some functions
-> ((TokenId,IdKind) -> Id)
-> IntState
-> [(a,PosLambda)]
-> ([(a,PosLambda)],IntState)
primCode flags magic tidFun state code =
case mapS primBindingTop code (flags,magic,True,tidFun (tident,Var))
(state,[]) of
(bs,(state,_)) -> (concat bs,state)
primBindingTop :: (a,PosLambda)
-> PrimMonad a [(a,PosLambda)]
primBindingTop (fun,lambda) =
primStrict True >=>
primLambda lambda >>>= \ lambda ->
primTop >>>= \ bs ->
unitS ((fun,lambda):bs)
primBinding :: (Id, PosLambda)
-> PrimMonad a (Id, PosLambda)
primBinding (fun,lambda) =
primLambda lambda >>>= \ lambda ->
unitS (fun,lambda)
primBindings :: [PosBinding] -> PrimMonad a [PosBinding]
primBindings bindings =
primBindings' [] (reverse bindings)
where
primBindings' acc [] = unitS (acc)
primBindings' acc (b:bs) =
primBinding b >>>= \ (b) ->
primBindings' (b:acc) bs
primLambda :: PosLambda -> PrimMonad a PosLambda
primLambda (PosLambda pos int free args@(_:_) exp) =
primStrict True >=> -- will be lifted later
primExp exp >>>= \ (exp) ->
unitS (PosLambda pos int free args exp)
primLambda (PosLambda pos int free args exp) =
primExp exp >>>= \ (exp) ->
unitS (PosLambda pos int free args exp)
primLambda l@(PosPrimitive pos fun) =
unitS l
primLambda l@(PosForeign pos fun ar t c ie) =
unitS l
primExp :: PosExp -> PrimMonad a PosExp
primExp (PosExpLambda pos int envs args exp) =
primStrict True >=> -- will be lifted later
primExp exp >>>= \ exp ->
unitS (PosExpLambda pos int envs args exp)
primExp (PosExpLet rec pos bindings exp) =
primExp exp >>>= \ exp ->
(primStrict False >=> primBindings bindings) >>>= \ (bindings) ->
unitS (PosExpLet rec pos bindings exp)
primExp (PosExpCase pos exp alts) =
primStrict True >=> -- If a case is lazy then lift it
mapS primAlt alts >>>= \ alts ->
primExp exp >>>= \ exp ->
unitS (PosExpCase pos exp alts)
primExp (PosExpFatBar b exp1 exp2) =
primExp exp2 >>>= \ exp2 ->
primExp exp1 >>>= \ exp1 ->
unitS (PosExpFatBar b exp1 exp2)
primExp (PosExpFail) =
unitS (PosExpFail)
primExp (PosExpIf pos g exp1 exp2 exp3) =
primStrict True >=> -- If an contitional is lazy then lift it
primExp exp2 >>>= \ exp2 ->
primExp exp3 >>>= \ exp3 ->
primExp exp1 >>>= \ exp1 ->
unitS (PosExpIf pos g exp1 exp2 exp3)
primExp (PosExpApp apos (PosVar pos fun:es)) =
-- (primStrict False >=> mapS primExp es) >>>= \ es ->
primExpand pos fun es
primExp (PosExpApp pos (e:es)) =
primExp e >>>= \ e ->
(primStrict False >=> mapS primExp es) >>>= \ es ->
unitS (PosExpApp pos (e:es))
primExp (PosVar pos fun) =
primExpand pos fun []
primExp e =
unitS e
primAlt :: PosAlt -> PrimMonad a PosAlt
primAlt (PosAltCon pos con args exp) =
primExp exp >>>= \ (exp) ->
unitS (PosAltCon pos con args exp)
primAlt (PosAltInt pos int b exp) =
primExp exp >>>= \ (exp) ->
unitS (PosAltInt pos int b exp)
---
strictPrim :: Prim -> [Bool]
strictPrim SEQ = True : repeat False
strictPrim _ = repeat True
primPrimitive :: Pos -> Prim -> Id -> Int -> [PosExp]
-> PrimMonad a PosExp
primPrimitive pos prim fun arity es =
mapS ( \ (s,e) -> primStrict s >=> primExp e) (zip (strictPrim prim) es) >>>= \ es ->
let need = arity - (length es)
in
if need <= 0 then
case splitAt arity es of
(args,eargs) -> unitS (posExpApp pos (PosExpThunk pos False (PosPrim pos prim fun:args) : eargs))
else
mapS ( \ _ -> primUnique ) (take need (repeat '_')) >>>= \ newargs ->
unitS (PosExpLambda pos True [] (map (pair pos) newargs) (PosExpThunk pos False (PosPrim pos prim fun : es ++ map (PosVar pos)
newargs)))
primApp :: Pos -> Id -> [PosExp]
-> PrimMonad a PosExp
primApp pos fun es =
(primStrict False >=> mapS primExp es) >>>= \ es ->
unitS (posExpApp pos (PosVar pos fun:es))
-- All args are already processed
primExpand :: Pos -> Id -> [PosExp]
-> PrimMonad a PosExp
primExpand pos fun es =
primFlags >>>= \ ((bool,logic,always),magic,strict) ->
primTidArity fun >>>= \ (arity,tid) ->
if not magic || (arity < 0 || not (strict || always)) then
-- this cannot be a primitive, or we don't translate unless strict
primApp pos fun es
else
case tid of
(Qualified3 _ (Qualified modcls cls) (Qualified modtyp typ) (Visible met))
| modcls == rpsPrelude && modtyp == rpsPrelude ->
if cls == rpsEq then
case (primOp bool typ,eqPrim met) of
(Just op,Just prim) -> primPrimitive pos (prim op) fun arity es
_ -> primApp pos fun es
else if cls == rpsOrd then
case (primOp bool typ,ordPrim met) of
(Just op,Just prim) -> primPrimitive pos (prim op) fun arity es
_ -> primApp pos fun es
else if cls == rpsNum then
case (primOp bool typ,numPrim met) of
(Just op,Just prim) -> primPrimitive pos (prim op) fun arity es
_ -> primApp pos fun es
else if cls == rpsIntegral then
case (primOp bool typ,integralPrim met) of
(Just op,Just prim) -> primPrimitive pos prim fun arity es
_ -> primApp pos fun es
else if cls == rpsEnum then
if typ == rpsChar &&
(met == rpstoEnum || met == rpsfromEnum) then
case es of
(f:[]) -> unitS f
[] -> primIdent pos
else
primApp pos fun es
else if cls == rpsFloating then
case (primOp bool typ,floatingPrim met) of
(Just op,Just prim) -> primPrimitive pos (prim op) fun arity es
_ -> primApp pos fun es
else if cls == rpsFractional then
case (primOp bool typ,fractionalPrim met) of
(Just op,Just prim) -> primPrimitive pos (prim op) fun arity es
_ -> primApp pos fun es
-- else if cls == rpsEval then
-- case (evalPrim met) of
-- (Just prim) -> primPrimitive pos prim 2 es
-- _ -> primApp pos fun es
else
primApp pos fun es
(Qualified3 _ (Visible modcls) underscore (Visible met))
| modcls == rpsPrelude && underscore == t_underscore && met == rpsseq ->
primPrimitive pos SEQ fun 2 (dropDicts es)
-- (Qualified3 (Qualified modcls cls) (Qualified modtyp typ) (Visible met))
-- | modcls == rpsPrelude && cls == rpsEval && met == rpsseq ->
-- primPrimitive pos SEQ 2 (dropDicts es)
(Qualified mod met) | mod == rpsPrelude ->
if met == rps_eqFloat then
primPrimitive pos (CMP_EQ OpFloat) fun 2 es
else if met == rps_eqDouble then
primPrimitive pos (CMP_EQ OpDouble) fun 2 es
else if met == rps_hGetStr && compiler==Nhc98 then
primPrimitive pos HGETS fun 1 es
else if met == rps_hGetChar && compiler==Nhc98 then
primPrimitive pos HGETC fun 1 es
else if met == rps_hPutChar && compiler==Nhc98 then
primPrimitive pos HPUTC fun 2 es
else if met == rps_unpackString {- && compiler==Yhc -} then
primPrimitive pos STRING fun 1 es
else if met == rps_catch then
primPrimitive pos CATCH fun 1 es
else if met == rps_fromEnum then
primPrimitive pos ORD fun 1 es
else if met == rps_toEnum && compiler==Nhc98 then
primPrimitive pos CHR fun 1 es
else if met == rpsseq then
primPrimitive pos SEQ fun 2 (dropDicts es)
else if logic then
if met == rpsAndAnd then
primPrimitive pos AND fun 2 es
else if met == rpsOrOr then
primPrimitive pos OR fun 2 es
else if met == rpsnot then
primPrimitive pos NOT fun 1 es
else
primApp pos fun es
else
primApp pos fun es
_ -> primApp pos fun es
-----------------
primTop :: PrimMonad a [(a,PosCode.PosLambda)]
primTop down up@(state,bs) =
(bs,(state,[]))
primUnique :: PrimMonad a Id
primUnique down up@(state,bs) =
case uniqueIS state of
(u,state) -> (u,(state,bs))
primIdent :: Pos -> PrimMonad a PosExp
primIdent pos down@(flags,magic,strict,ident) up =
(PosVar pos ident,up)
primFlags :: PrimMonad a ((Bool,Bool,Bool),Bool,Bool)
primFlags down@(flags,magic,strict,ident) up =
((flags,magic,strict),up)
primStrict :: Bool -> PrimMonad a PrimDown
primStrict s down@(flags,magic,strict,ident) up =
((flags,magic,s,ident),up)
primTidArity :: Id -> PrimMonad a (Int, TokenId)
primTidArity i down up@(state,bs) =
case lookupIS state i of
Just info -> ((arityIS state i,tidI info),up) -- count ctx
Nothing -> ((-1,error "arg"),up) -- It's an argument, don't look :-)
-- =============================================================
impRev :: String -> PackedString
impRev str = packString (reverse str)
--------------
rpsEq, rpsOrd, rpsNum, rpsFloating, rpsIntegral, rpsFractional, rpsEnum :: PackedString
rpsEq = impRev "Eq"
rpsOrd = impRev "Ord"
rpsNum = impRev "Num"
rpsFloating = impRev "Floating"
rpsIntegral = impRev "Integral"
rpsFractional = impRev "Fractional"
rpsEnum = impRev "Enum"
--rpsEval = impRev "Eval" -- Removed in Haskell 98
rps_eqFloat, rps_eqDouble :: PackedString
rps_eqFloat = impRev "_eqFloat"
rps_eqDouble = impRev "_eqDouble"
rpsAndAnd, rpsOrOr, rpsnot, rps_fromEnum, rps_toEnum, rps_hGetStr, rps_hGetChar, rps_hPutChar
,rps_unpackString :: PackedString
rpsAndAnd = impRev "&&"
rpsOrOr = impRev "||"
rpsnot = impRev "not"
rps_fromEnum = impRev "_fromEnum"
rps_toEnum = impRev "_toEnum"
rps_hGetStr = impRev "_hGetStr"
rps_hGetChar = impRev "_hGetChar"
rps_hPutChar = impRev "_hPutChar"
rps_unpackString = impRev "_unpackString"
rps_catch = impRev "_catch"
--------------
eqPrim :: PackedString -> Maybe (PrimOp -> Prim)
eqPrim met =
if met == rpseq then Just CMP_EQ
else if met == rpsne then Just CMP_NE
else Nothing
rpseq, rpsne :: PackedString
rpseq = impRev "=="
rpsne = impRev "/="
--------------
ordPrim :: PackedString -> Maybe (PrimOp -> Prim)
ordPrim met =
if met == rpslt then Just CMP_LT
else if met == rpsle then Just CMP_LE
else if met == rpsgt then Just CMP_GT
else if met == rpsge then Just CMP_GE
else Nothing
rpslt, rpsle, rpsgt, rpsge :: PackedString
rpslt = impRev "<"
rpsle = impRev "<="
rpsgt = impRev ">"
rpsge = impRev ">="
--------------------
primOp :: Bool -> PackedString -> Maybe PrimOp
primOp bool typ =
if typ == rpsInt then Just OpWord
else if typ == rpsChar then Just OpWord
else if bool && typ == rpsBool then Just OpWord
else if typ == rpsDouble then Just OpDouble
else if typ == rpsFloat then Just OpFloat
else Nothing
rpsInt, rpsChar, rpsBool, rpsDouble, rpsFloat :: PackedString
rpsInt = impRev "Int"
rpsChar = impRev "Char"
rpsBool = impRev "Bool"
rpsDouble = impRev "Double"
rpsFloat = impRev "Float"
-------------------
rpstoEnum, rpsfromEnum :: PackedString
rpstoEnum = impRev "toEnum"
rpsfromEnum = impRev "fromEnum"
--------------------
numPrim :: PackedString -> Maybe (PrimOp -> Prim)
numPrim met =
if met == rpssignum && compiler==Nhc98 then Just SIGNUM
else if met == rpsabs && compiler==Nhc98 then Just ABS
else if met == rpsnegate then Just NEG
else if met == rpsadd then Just ADD
else if met == rpssub then Just SUB
else if met == rpsmul then Just MUL
else Nothing
rpsadd, rpssub, rpsmul, rpsabs, rpssignum, rpsnegate :: PackedString
rpsadd = impRev "+"
rpssub = impRev "-"
rpsmul = impRev "*"
rpsabs = impRev "abs"
rpssignum = impRev "signum"
rpsnegate = impRev "negate"
--------------
integralPrim :: PackedString -> Maybe Prim
integralPrim met =
if met == rpsquot then Just QUOT
else if met == rpsrem then Just REM
else Nothing
rpsquot, rpsrem :: PackedString
rpsquot = impRev "quot"
rpsrem = impRev "rem"
--------------
floatingPrim :: PackedString -> Maybe (PrimOp -> Prim)
floatingPrim met | compiler==Yhc = Nothing
floatingPrim met | compiler==Nhc98 =
if met == rpsexp then Just EXP
else if met == rpslog then Just LOG
else if met == rpssqrt then Just SQRT
else if met == rpssin then Just SIN
else if met == rpscos then Just COS
else if met == rpstan then Just TAN
else if met == rpsasin then Just ASIN
else if met == rpsacos then Just ACOS
else if met == rpsatan then Just ATAN
else if met == rpspow then Just POW
else Nothing
rpsexp,rpslog,rpssqrt,rpssin,rpscos,rpstan,rpsasin,rpsacos,rpsatan,rpspow :: PackedString
rpsexp = impRev "exp"
rpslog = impRev "log"
rpssqrt = impRev "sqrt"
rpssin = impRev "sin"
rpscos = impRev "cos"
rpstan = impRev "tan"
rpsasin = impRev "asin"
rpsacos = impRev "acos"
rpsatan = impRev "atan"
rpspow = impRev "**"
--------------
fractionalPrim :: PackedString -> Maybe (PrimOp -> Prim)
fractionalPrim met =
if met == rpsslash then Just SLASH
else Nothing
rpsslash :: PackedString
rpsslash = impRev "/"
--------------
rpsseq :: PackedString
rpsseq = impRev "_seq"
---- ======================================================
dropDicts :: [PosExp] -> [PosExp]
dropDicts (PosExpDict _:es) = dropDicts es
dropDicts es = es
|
